Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit aa07bad

Browse files
committed
Merge remote-tracking branch 'origin/cwd' into cwd
2 parents 0c5bcfb + b6a92e8 commit aa07bad

File tree

9 files changed

+645
-64
lines changed

9 files changed

+645
-64
lines changed

‎.github/collab.sh‎

100644100755
File mode changed.

‎doc/specs/stdlib_ascii.md‎

Lines changed: 530 additions & 3 deletions
Large diffs are not rendered by default.

‎doc/specs/stdlib_system.md‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -756,6 +756,8 @@ None.
756756
{!example/system/example_null_device.f90!}
757757
```
758758

759+
---
760+
759761
## `delete_file` - Delete a file
760762

761763
### Status

‎src/CMakeLists.txt‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -117,6 +117,7 @@ set(SRC
117117
stdlib_sorting_radix_sort.f90
118118
stdlib_system_subprocess.c
119119
stdlib_system_subprocess.F90
120+
stdlib_system.c
120121
stdlib_system_path.f90
121122
stdlib_system.c
122123
stdlib_system.F90

‎src/stdlib_ascii.fypp‎

Lines changed: 14 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -107,47 +107,47 @@ module stdlib_ascii
107107
contains
108108

109109
!> Checks whether `c` is an ASCII letter (A .. Z, a .. z).
110-
pure logical function is_alpha(c)
110+
elemental logical function is_alpha(c)
111111
character(len=1), intent(in) :: c !! The character to test.
112112
is_alpha = (c >= 'A' .and. c <= 'Z') .or. (c >= 'a' .and. c <= 'z')
113113
end function
114114

115115
!> Checks whether `c` is a letter or a number (0 .. 9, a .. z, A .. Z).
116-
pure logical function is_alphanum(c)
116+
elemental logical function is_alphanum(c)
117117
character(len=1), intent(in) :: c !! The character to test.
118118
is_alphanum = (c >= '0' .and. c <= '9') .or. (c >= 'a' .and. c <= 'z') &
119119
.or. (c >= 'A' .and. c <= 'Z')
120120
end function
121121

122122
!> Checks whether or not `c` is in the ASCII character set -
123123
!> i.e. in the range 0 .. 0x7F.
124-
pure logical function is_ascii(c)
124+
elemental logical function is_ascii(c)
125125
character(len=1), intent(in) :: c !! The character to test.
126126
is_ascii = iachar(c) <= int(z'7F')
127127
end function
128128

129129
!> Checks whether `c` is a control character.
130-
pure logical function is_control(c)
130+
elemental logical function is_control(c)
131131
character(len=1), intent(in) :: c !! The character to test.
132132
integer :: ic
133133
ic = iachar(c)
134134
is_control = ic < int(z'20') .or. ic == int(z'7F')
135135
end function
136136

137137
!> Checks whether `c` is a digit (0 .. 9).
138-
pure logical function is_digit(c)
138+
elemental logical function is_digit(c)
139139
character(len=1), intent(in) :: c !! The character to test.
140140
is_digit = ('0' <= c) .and. (c <= '9')
141141
end function
142142

143143
!> Checks whether `c` is a digit in base 8 (0 .. 7).
144-
pure logical function is_octal_digit(c)
144+
elemental logical function is_octal_digit(c)
145145
character(len=1), intent(in) :: c !! The character to test.
146146
is_octal_digit = (c >= '0') .and. (c <= '7');
147147
end function
148148

149149
!> Checks whether `c` is a digit in base 16 (0 .. 9, A .. F, a .. f).
150-
pure logical function is_hex_digit(c)
150+
elemental logical function is_hex_digit(c)
151151
character(len=1), intent(in) :: c !! The character to test.
152152
is_hex_digit = (c >= '0' .and. c <= '9') .or. (c >= 'a' .and. c <= 'f') &
153153
.or. (c >= 'A' .and. c <= 'F')
@@ -156,7 +156,7 @@ contains
156156
!> Checks whether or not `c` is a punctuation character. That includes
157157
!> all ASCII characters which are not control characters, letters,
158158
!> digits, or whitespace.
159-
pure logical function is_punctuation(c)
159+
elemental logical function is_punctuation(c)
160160
character(len=1), intent(in) :: c !! The character to test.
161161
integer :: ic
162162
ic = iachar(c) ! '~' '!'
@@ -166,7 +166,7 @@ contains
166166

167167
!> Checks whether or not `c` is a printable character other than the
168168
!> space character.
169-
pure logical function is_graphical(c)
169+
elemental logical function is_graphical(c)
170170
character(len=1), intent(in) :: c !! The character to test.
171171
integer :: ic
172172
ic = iachar(c)
@@ -177,7 +177,7 @@ contains
177177

178178
!> Checks whether or not `c` is a printable character - including the
179179
!> space character.
180-
pure logical function is_printable(c)
180+
elemental logical function is_printable(c)
181181
character(len=1), intent(in) :: c !! The character to test.
182182
integer :: ic
183183
ic = iachar(c)
@@ -186,23 +186,23 @@ contains
186186
end function
187187

188188
!> Checks whether `c` is a lowercase ASCII letter (a .. z).
189-
pure logical function is_lower(c)
189+
elemental logical function is_lower(c)
190190
character(len=1), intent(in) :: c !! The character to test.
191191
integer :: ic
192192
ic = iachar(c)
193193
is_lower = ic >= iachar('a') .and. ic <= iachar('z')
194194
end function
195195

196196
!> Checks whether `c` is an uppercase ASCII letter (A .. Z).
197-
pure logical function is_upper(c)
197+
elemental logical function is_upper(c)
198198
character(len=1), intent(in) :: c !! The character to test.
199199
is_upper = (c >= 'A') .and. (c <= 'Z')
200200
end function
201201

202202
!> Checks whether or not `c` is a whitespace character. That includes the
203203
!> space, tab, vertical tab, form feed, carriage return, and linefeed
204204
!> characters.
205-
pure logical function is_white(c)
205+
elemental logical function is_white(c)
206206
character(len=1), intent(in) :: c !! The character to test.
207207
integer :: ic
208208
ic = iachar(c) ! TAB, LF, VT, FF, CR
@@ -211,7 +211,7 @@ contains
211211

212212
!> Checks whether or not `c` is a blank character. That includes the
213213
!> only the space and tab characters
214-
pure logical function is_blank(c)
214+
elemental logical function is_blank(c)
215215
character(len=1), intent(in) :: c !! The character to test.
216216
integer :: ic
217217
ic = iachar(c) ! TAB

‎src/stdlib_intrinsics_dot_product.fypp‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -34,10 +34,10 @@ pure module function stdlib_dot_product_${s}$(a,b) result(p)
3434
n = size(a,kind=ilp)
3535
r = mod(n,chunk)
3636

37-
abatch(1:r) = a(1:r)*${cnjg(t,'b(1:r)')}$
37+
abatch(1:r) = ${cnjg(t,'a(1:r)')}$*b(1:r)
3838
abatch(r+1:chunk) = zero_${s}$
3939
do i = r+1, n-r, chunk
40-
abatch(1:chunk) = abatch(1:chunk) + a(i:i+chunk-1)*${cnjg(t,'b(i:i+chunk-1)')}$
40+
abatch(1:chunk) = abatch(1:chunk) + ${cnjg(t,'a(i:i+chunk-1)')}$*b(i:i+chunk-1)
4141
end do
4242

4343
p = zero_${s}$
@@ -60,11 +60,11 @@ pure module function stdlib_dot_product_kahan_${s}$(a,b) result(p)
6060
n = size(a,kind=ilp)
6161
r = mod(n,chunk)
6262

63-
abatch(1:r) = a(1:r)*${cnjg(t,'b(1:r)')}$
63+
abatch(1:r) = ${cnjg(t,'a(1:r)')}$*b(1:r)
6464
abatch(r+1:chunk) = zero_${s}$
6565
cbatch = zero_${s}$
6666
do i = r+1, n-r, chunk
67-
call kahan_kernel( a(i:i+chunk-1)*${cnjg(t,'b(i:i+chunk-1)')}$ , abatch(1:chunk) , cbatch(1:chunk) )
67+
call kahan_kernel( ${cnjg(t,'a(i:i+chunk-1)')}$*b(i:i+chunk-1) , abatch(1:chunk) , cbatch(1:chunk) )
6868
end do
6969

7070
p = zero_${s}$

‎src/stdlib_system.c‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
11
#include <limits.h>
22
#include <stddef.h>
33
#include <stdlib.h>
4+
#include <stddef.h>
5+
#include <stdlib.h>
46
#include <sys/stat.h>
57
#include <sys/types.h>
68
#include <string.h>
@@ -43,7 +45,6 @@ int stdlib_remove_directory(const char* path){
4345
#else
4446
code = rmdir(path);
4547
#endif /* ifdef _WIN32 */
46-
4748
return (!code) ? 0 : errno;
4849
}
4950

‎test/ascii/test_ascii.f90‎

Lines changed: 71 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,7 @@ subroutine collect_ascii(testsuite)
5252
new_unittest("to_lower_long", test_to_lower_long), &
5353
new_unittest("to_upper_short", test_to_upper_short), &
5454
new_unittest("to_upper_long", test_to_upper_long), &
55+
new_unittest("ascii_table", test_ascii_table), &
5556
new_unittest("to_upper_string", test_to_upper_string), &
5657
new_unittest("to_lower_string", test_to_lower_string), &
5758
new_unittest("to_title_string", test_to_title_string), &
@@ -725,52 +726,27 @@ subroutine test_to_upper_long(error)
725726
! This test reproduces the true/false table found at
726727
! https://en.cppreference.com/w/cpp/string/byte
727728
!
728-
subroutine test_ascii_table
729+
subroutine ascii_table(table)
730+
logical, intent(out) :: table(15,12)
729731
integer :: i, j
730-
logical :: table(15,12)
731-
732-
abstract interface
733-
pure logical function validation_func_interface(c)
734-
character(len=1), intent(in) :: c
735-
end function
736-
end interface
737-
738-
type :: proc_pointer_array
739-
procedure(validation_func_interface), pointer, nopass :: pcf
740-
end type proc_pointer_array
741-
742-
type(proc_pointer_array) :: pcfs(12)
743-
744-
pcfs(1)%pcf => is_control
745-
pcfs(2)%pcf => is_printable
746-
pcfs(3)%pcf => is_white
747-
pcfs(4)%pcf => is_blank
748-
pcfs(5)%pcf => is_graphical
749-
pcfs(6)%pcf => is_punctuation
750-
pcfs(7)%pcf => is_alphanum
751-
pcfs(8)%pcf => is_alpha
752-
pcfs(9)%pcf => is_upper
753-
pcfs(10)%pcf => is_lower
754-
pcfs(11)%pcf => is_digit
755-
pcfs(12)%pcf => is_hex_digit
756732

757733
! loop through functions
758734
do i = 1, 12
759-
table(1,i) = all([(pcfs(i)%pcf(achar(j)),j=0,8)])! control codes
760-
table(2,i) = pcfs(i)%pcf(achar(9)) ! tab
761-
table(3,i) = all([(pcfs(i)%pcf(achar(j)),j=10,13)])! whitespaces
762-
table(4,i) = all([(pcfs(i)%pcf(achar(j)),j=14,31)])! control codes
763-
table(5,i) = pcfs(i)%pcf(achar(32)) ! space
764-
table(6,i) = all([(pcfs(i)%pcf(achar(j)),j=33,47)])! !"#$%&'()*+,-./
765-
table(7,i) = all([(pcfs(i)%pcf(achar(j)),j=48,57)])! 0123456789
766-
table(8,i) = all([(pcfs(i)%pcf(achar(j)),j=58,64)])! :;<=>?@
767-
table(9,i) = all([(pcfs(i)%pcf(achar(j)),j=65,70)])! ABCDEF
768-
table(10,i) = all([(pcfs(i)%pcf(achar(j)),j=71,90)])! GHIJKLMNOPQRSTUVWXYZ
769-
table(11,i) = all([(pcfs(i)%pcf(achar(j)),j=91,96)])! [\]^_`
770-
table(12,i) = all([(pcfs(i)%pcf(achar(j)),j=97,102)])! abcdef
771-
table(13,i) = all([(pcfs(i)%pcf(achar(j)),j=103,122)])! ghijklmnopqrstuvwxyz
772-
table(14,i) = all([(pcfs(i)%pcf(achar(j)),j=123,126)])! {|}~
773-
table(15,i) = pcfs(i)%pcf(achar(127)) ! backspace character
735+
table(1,i) = all([(validate(j,i), j=0,8)])
736+
table(2,i) = validate(9,i)
737+
table(3,i) = all([(validate(j,i), j=10,13)])
738+
table(4,i) = all([(validate(j,i), j=14,31)])
739+
table(5,i) = validate(32,i)
740+
table(6,i) = all([(validate(j,i), j=33,47)])
741+
table(7,i) = all([(validate(j,i), j=48,57)])
742+
table(8,i) = all([(validate(j,i), j=58,64)])
743+
table(9,i) = all([(validate(j,i), j=65,70)])
744+
table(10,i) = all([(validate(j,i), j=71,90)])
745+
table(11,i) = all([(validate(j,i), j=91,96)])
746+
table(12,i) = all([(validate(j,i), j=97,102)])
747+
table(13,i) = all([(validate(j,i), j=103,122)])
748+
table(14,i) = all([(validate(j,i), j=123,126)])
749+
table(15,i) = validate(127,i)
774750
end do
775751

776752
! output table for verification
@@ -779,6 +755,59 @@ pure logical function validation_func_interface(c)
779755
write(*,'(I3,2X,12(L4),2X,I3)') j, (table(j,i),i=1,12), count(table(j,:))
780756
end do
781757
write(*,'(5X,12(I4))') (count(table(:,i)),i=1,12)
758+
759+
contains
760+
761+
elemental logical function validate(ascii_code, func)
762+
integer, intent(in) :: ascii_code, func
763+
character(len=1) :: c
764+
765+
c = achar(ascii_code)
766+
767+
select case (func)
768+
case (1); validate = is_control(c)
769+
case (2); validate = is_printable(c)
770+
case (3); validate = is_white(c)
771+
case (4); validate = is_blank(c)
772+
case (5); validate = is_graphical(c)
773+
case (6); validate = is_punctuation(c)
774+
case (7); validate = is_alphanum(c)
775+
case (8); validate = is_alpha(c)
776+
case (9); validate = is_upper(c)
777+
case (10); validate = is_lower(c)
778+
case (11); validate = is_digit(c)
779+
case (12); validate = is_hex_digit(c)
780+
case default; validate = .false.
781+
end select
782+
end function validate
783+
784+
end subroutine ascii_table
785+
786+
subroutine test_ascii_table(error)
787+
type(error_type), allocatable, intent(out) :: error
788+
logical :: arr(15, 12)
789+
logical, parameter :: ascii_class_table(15,12) = transpose(reshape([ &
790+
! iscntrl isprint isspace isblank isgraph ispunct isalnum isalpha isupper islower isdigit isxdigit
791+
.true., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., & ! 0–8
792+
.true., .false., .true., .true., .false., .false., .false., .false., .false., .false., .false., .false., & ! 9
793+
.true., .false., .true., .false., .false., .false., .false., .false., .false., .false., .false., .false., & ! 10–13
794+
.true., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., & ! 14–31
795+
.false., .true., .true., .true., .false., .false., .false., .false., .false., .false., .false., .false., & ! 32 (space)
796+
.false., .true., .false., .false., .true., .true., .false., .false., .false., .false., .false., .false., & ! 33–47
797+
.false., .true., .false., .false., .true., .false., .true., .false., .false., .false., .true., .true., & ! 48–57
798+
.false., .true., .false., .false., .true., .true., .false., .false., .false., .false., .false., .false., & ! 58–64
799+
.false., .true., .false., .false., .true., .false., .true., .true., .true., .false., .false., .true., & ! 65–70
800+
.false., .true., .false., .false., .true., .false., .true., .true., .true., .false., .false., .false., & ! 71–90
801+
.false., .true., .false., .false., .true., .true., .false., .false., .false., .false., .false., .false., & ! 91–96
802+
.false., .true., .false., .false., .true., .false., .true., .true., .false., .true., .false., .true., & ! 97–102
803+
.false., .true., .false., .false., .true., .false., .true., .true., .false., .true., .false., .false., & ! 103–122
804+
.false., .true., .false., .false., .true., .true., .false., .false., .false., .false., .false., .false., & ! 123–126
805+
.true., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false. & ! 127
806+
], shape=[12,15]))
807+
808+
call ascii_table(arr)
809+
call check(error, all(arr .eqv. ascii_class_table), "ascii table was not accurately generated")
810+
782811
end subroutine test_ascii_table
783812

784813
subroutine test_to_lower_string(error)

‎test/intrinsics/test_intrinsics.fypp‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -246,6 +246,27 @@ subroutine test_dot_product(error)
246246
call check(error, all(err(:)<tolerance) , "complex dot_product is not accurate" )
247247
if (allocated(error)) return
248248
end block
249+
250+
block ! test for https://github.com/fortran-lang/stdlib/issues/1016
251+
${t}$ :: x(128), y(128)
252+
real(${k}$) :: z(128,2)
253+
real(${k}$), parameter :: tolerance = epsilon(1._${k}$)*100000
254+
real(${k}$) :: err(2)
255+
${t}$ :: p(3)
256+
257+
call random_number(z)
258+
x%re = z(:, 1); x%im = z(:, 2)
259+
call random_number(z)
260+
y%re = z(:, 1); y%im = z(:, 2)
261+
262+
p(1) = dot_product(x,y) ! compiler intrinsic
263+
p(2) = stdlib_dot_product_kahan(x,y) ! chunked Kahan dot_product
264+
p(3) = stdlib_dot_product(x,y) ! chunked dot_product
265+
err(1:2) = sqrt((p(2:3)%re - p(1)%re)**2 + (p(2:3)%im - p(1)%im)**2)
266+
267+
call check(error, all(err(:)<tolerance) , "complex dot_product does not conform to the standard" )
268+
if (allocated(error)) return
269+
end block
249270
#:endfor
250271

251272
end subroutine

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /