Merge remote-tracking branch 'origin/cwd' into cwd

wassup05 · wassup05 · commit aa07bad0a36d · 2025-07-30T22:42:29.000+05:30
diff --git a/.github/collab.sh b/.github/collab.sh
diff --git a/doc/specs/stdlib_ascii.md b/doc/specs/stdlib_ascii.md
diff --git a/doc/specs/stdlib_system.md b/doc/specs/stdlib_system.md
@@ -756,6 +756,8 @@ None.
 {!example/system/example_null_device.f90!}
 ```
 
+---
+
 ## `delete_file` - Delete a file
 
 ### Status
diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt
@@ -117,6 +117,7 @@ set(SRC
     stdlib_sorting_radix_sort.f90
     stdlib_system_subprocess.c
     stdlib_system_subprocess.F90
+    stdlib_system.c
     stdlib_system_path.f90
     stdlib_system.c
     stdlib_system.F90
diff --git a/src/stdlib_ascii.fypp b/src/stdlib_ascii.fypp
@@ -107,47 +107,47 @@ module stdlib_ascii
 contains
 
     !> Checks whether `c` is an ASCII letter (A .. Z, a .. z).
-    pure logical function is_alpha(c)
+    elemental logical function is_alpha(c)
         character(len=1), intent(in) :: c !! The character to test.
         is_alpha = (c >= 'A' .and. c <= 'Z') .or. (c >= 'a' .and. c <= 'z')
     end function
 
     !> Checks whether `c` is a letter or a number (0 .. 9, a .. z, A .. Z).
-    pure logical function is_alphanum(c)
+    elemental logical function is_alphanum(c)
         character(len=1), intent(in) :: c !! The character to test.
         is_alphanum = (c >= '0' .and. c <= '9') .or. (c >= 'a' .and. c <= 'z') &
             .or. (c >= 'A' .and. c <= 'Z')
     end function
 
     !> Checks whether or not `c` is in the ASCII character set -
     !> i.e. in the range 0 .. 0x7F.
-    pure logical function is_ascii(c)
+    elemental logical function is_ascii(c)
         character(len=1), intent(in) :: c !! The character to test.
         is_ascii = iachar(c) <= int(z'7F')
     end function
 
     !> Checks whether `c` is a control character.
-    pure logical function is_control(c)
+    elemental logical function is_control(c)
         character(len=1), intent(in) :: c !! The character to test.
         integer :: ic
         ic = iachar(c)
         is_control = ic < int(z'20') .or. ic == int(z'7F')
     end function
 
     !> Checks whether `c` is a digit (0 .. 9).
-    pure logical function is_digit(c)
+    elemental logical function is_digit(c)
         character(len=1), intent(in) :: c !! The character to test.
         is_digit = ('0' <= c) .and. (c <= '9')
     end function
 
     !> Checks whether `c` is a digit in base 8 (0 .. 7).
-    pure logical function is_octal_digit(c)
+    elemental logical function is_octal_digit(c)
         character(len=1), intent(in) :: c !! The character to test.
         is_octal_digit = (c >= '0') .and. (c <= '7');
     end function
 
     !> Checks whether `c` is a digit in base 16 (0 .. 9, A .. F, a .. f).
-    pure logical function is_hex_digit(c)
+    elemental logical function is_hex_digit(c)
         character(len=1), intent(in) :: c !! The character to test.
         is_hex_digit = (c >= '0' .and. c <= '9') .or. (c >= 'a' .and. c <= 'f') &
             .or. (c >= 'A' .and. c <= 'F')
@@ -156,7 +156,7 @@ contains
     !> Checks whether or not `c` is a punctuation character. That includes
     !> all ASCII characters which are not control characters, letters,
     !> digits, or whitespace.
-    pure logical function is_punctuation(c)
+    elemental logical function is_punctuation(c)
         character(len=1), intent(in) :: c !! The character to test.
         integer :: ic
         ic = iachar(c) !       '~'                 '!'
@@ -166,7 +166,7 @@ contains
 
     !> Checks whether or not `c` is a printable character other than the
     !> space character.
-    pure logical function is_graphical(c)
+    elemental logical function is_graphical(c)
         character(len=1), intent(in) :: c !! The character to test.
         integer :: ic
         ic = iachar(c)
@@ -177,7 +177,7 @@ contains
 
     !> Checks whether or not `c` is a printable character - including the
     !> space character.
-    pure logical function is_printable(c)
+    elemental logical function is_printable(c)
         character(len=1), intent(in) :: c !! The character to test.
         integer :: ic
         ic = iachar(c)
@@ -186,23 +186,23 @@ contains
     end function
 
     !> Checks whether `c` is a lowercase ASCII letter (a .. z).
-    pure logical function is_lower(c)
+    elemental logical function is_lower(c)
         character(len=1), intent(in) :: c !! The character to test.
         integer :: ic
         ic = iachar(c)
         is_lower = ic >= iachar('a') .and. ic <= iachar('z')
     end function
 
     !> Checks whether `c` is an uppercase ASCII letter (A .. Z).
-    pure logical function is_upper(c)
+    elemental logical function is_upper(c)
         character(len=1), intent(in) :: c !! The character to test.
         is_upper = (c >= 'A') .and. (c <= 'Z')
     end function
 
     !> Checks whether or not `c` is a whitespace character. That includes the
     !> space, tab, vertical tab, form feed, carriage return, and linefeed
     !> characters.
-    pure logical function is_white(c)
+    elemental logical function is_white(c)
         character(len=1), intent(in) :: c !! The character to test.
         integer :: ic
         ic = iachar(c)             ! TAB, LF, VT, FF, CR
@@ -211,7 +211,7 @@ contains
 
     !> Checks whether or not `c` is a blank character. That includes the
     !> only the space and tab characters
-    pure logical function is_blank(c)
+    elemental logical function is_blank(c)
         character(len=1), intent(in) :: c !! The character to test.
         integer :: ic
         ic = iachar(c)             ! TAB
diff --git a/src/stdlib_intrinsics_dot_product.fypp b/src/stdlib_intrinsics_dot_product.fypp
@@ -34,10 +34,10 @@ pure module function stdlib_dot_product_${s}$(a,b) result(p)
     n = size(a,kind=ilp)
     r = mod(n,chunk)
 
-    abatch(1:r)       = a(1:r)*${cnjg(t,'b(1:r)')}$
+    abatch(1:r)       = ${cnjg(t,'a(1:r)')}$*b(1:r)
     abatch(r+1:chunk) = zero_${s}$
     do i = r+1, n-r, chunk
-        abatch(1:chunk) = abatch(1:chunk) + a(i:i+chunk-1)*${cnjg(t,'b(i:i+chunk-1)')}$
+        abatch(1:chunk) = abatch(1:chunk) + ${cnjg(t,'a(i:i+chunk-1)')}$*b(i:i+chunk-1)
     end do
 
     p = zero_${s}$
@@ -60,11 +60,11 @@ pure module function stdlib_dot_product_kahan_${s}$(a,b) result(p)
     n = size(a,kind=ilp)
     r = mod(n,chunk)
 
-    abatch(1:r)       = a(1:r)*${cnjg(t,'b(1:r)')}$
+    abatch(1:r)       = ${cnjg(t,'a(1:r)')}$*b(1:r)
     abatch(r+1:chunk) = zero_${s}$
     cbatch = zero_${s}$
     do i = r+1, n-r, chunk
-        call kahan_kernel( a(i:i+chunk-1)*${cnjg(t,'b(i:i+chunk-1)')}$ , abatch(1:chunk) , cbatch(1:chunk) )
+        call kahan_kernel( ${cnjg(t,'a(i:i+chunk-1)')}$*b(i:i+chunk-1) , abatch(1:chunk) , cbatch(1:chunk) )
     end do     
 
     p = zero_${s}$
diff --git a/src/stdlib_system.c b/src/stdlib_system.c
@@ -1,6 +1,8 @@
 #include <limits.h>
 #include <stddef.h>
 #include <stdlib.h>
+#include <stddef.h>
+#include <stdlib.h>
 #include <sys/stat.h>
 #include <sys/types.h>
 #include <string.h>
@@ -43,7 +45,6 @@ int stdlib_remove_directory(const char* path){
 #else
     code = rmdir(path);
 #endif /* ifdef _WIN32 */
-
     return (!code) ? 0 : errno;
 }
 
diff --git a/test/ascii/test_ascii.f90 b/test/ascii/test_ascii.f90
@@ -52,6 +52,7 @@ subroutine collect_ascii(testsuite)
             new_unittest("to_lower_long", test_to_lower_long), &
             new_unittest("to_upper_short", test_to_upper_short), &
             new_unittest("to_upper_long", test_to_upper_long), &
+            new_unittest("ascii_table", test_ascii_table), &
             new_unittest("to_upper_string", test_to_upper_string), &
             new_unittest("to_lower_string", test_to_lower_string), &
             new_unittest("to_title_string", test_to_title_string), &
@@ -725,52 +726,27 @@ subroutine test_to_upper_long(error)
     !   This test reproduces the true/false table found at
     !   https://en.cppreference.com/w/cpp/string/byte
     !
-    subroutine test_ascii_table
+    subroutine ascii_table(table)
+        logical, intent(out) :: table(15,12)
         integer :: i, j
-        logical :: table(15,12)
-
-        abstract interface
-            pure logical function validation_func_interface(c)
-                character(len=1), intent(in) :: c
-            end function
-        end interface
-
-        type :: proc_pointer_array
-            procedure(validation_func_interface), pointer, nopass :: pcf
-        end type proc_pointer_array
-
-        type(proc_pointer_array) :: pcfs(12)
-
-        pcfs(1)%pcf => is_control
-        pcfs(2)%pcf => is_printable
-        pcfs(3)%pcf => is_white
-        pcfs(4)%pcf => is_blank
-        pcfs(5)%pcf => is_graphical
-        pcfs(6)%pcf => is_punctuation
-        pcfs(7)%pcf => is_alphanum
-        pcfs(8)%pcf => is_alpha
-        pcfs(9)%pcf => is_upper
-        pcfs(10)%pcf => is_lower
-        pcfs(11)%pcf => is_digit
-        pcfs(12)%pcf => is_hex_digit
 
         ! loop through functions
         do i = 1, 12
-            table(1,i)  = all([(pcfs(i)%pcf(achar(j)),j=0,8)])      ! control codes
-            table(2,i)  = pcfs(i)%pcf(achar(9))                     ! tab
-            table(3,i)  = all([(pcfs(i)%pcf(achar(j)),j=10,13)])    ! whitespaces
-            table(4,i)  = all([(pcfs(i)%pcf(achar(j)),j=14,31)])    ! control codes
-            table(5,i)  = pcfs(i)%pcf(achar(32))                    ! space
-            table(6,i)  = all([(pcfs(i)%pcf(achar(j)),j=33,47)])    ! !"#$%&'()*+,-./
-            table(7,i)  = all([(pcfs(i)%pcf(achar(j)),j=48,57)])    ! 0123456789
-            table(8,i)  = all([(pcfs(i)%pcf(achar(j)),j=58,64)])    ! :;<=>?@
-            table(9,i)  = all([(pcfs(i)%pcf(achar(j)),j=65,70)])    ! ABCDEF
-            table(10,i) = all([(pcfs(i)%pcf(achar(j)),j=71,90)])    ! GHIJKLMNOPQRSTUVWXYZ
-            table(11,i) = all([(pcfs(i)%pcf(achar(j)),j=91,96)])    ! [\]^_`
-            table(12,i) = all([(pcfs(i)%pcf(achar(j)),j=97,102)])   ! abcdef
-            table(13,i) = all([(pcfs(i)%pcf(achar(j)),j=103,122)])  ! ghijklmnopqrstuvwxyz
-            table(14,i) = all([(pcfs(i)%pcf(achar(j)),j=123,126)])  ! {|}~
-            table(15,i) = pcfs(i)%pcf(achar(127))                   ! backspace character
+            table(1,i)  = all([(validate(j,i), j=0,8)])
+            table(2,i)  = validate(9,i)
+            table(3,i)  = all([(validate(j,i), j=10,13)])
+            table(4,i)  = all([(validate(j,i), j=14,31)])
+            table(5,i)  = validate(32,i)
+            table(6,i)  = all([(validate(j,i), j=33,47)])
+            table(7,i)  = all([(validate(j,i), j=48,57)])
+            table(8,i)  = all([(validate(j,i), j=58,64)])
+            table(9,i)  = all([(validate(j,i), j=65,70)])
+            table(10,i) = all([(validate(j,i), j=71,90)])
+            table(11,i) = all([(validate(j,i), j=91,96)])
+            table(12,i) = all([(validate(j,i), j=97,102)])
+            table(13,i) = all([(validate(j,i), j=103,122)])
+            table(14,i) = all([(validate(j,i), j=123,126)])
+            table(15,i) = validate(127,i)
         end do
 
         ! output table for verification
@@ -779,6 +755,59 @@ pure logical function validation_func_interface(c)
             write(*,'(I3,2X,12(L4),2X,I3)') j, (table(j,i),i=1,12), count(table(j,:))
         end do
         write(*,'(5X,12(I4))') (count(table(:,i)),i=1,12)
+ 
+        contains
+
+            elemental logical function validate(ascii_code, func)
+                integer, intent(in) :: ascii_code, func
+                character(len=1) :: c
+            
+                c = achar(ascii_code)
+            
+                select case (func)
+                    case (1);     validate = is_control(c)
+                    case (2);     validate = is_printable(c)
+                    case (3);     validate = is_white(c)
+                    case (4);     validate = is_blank(c)
+                    case (5);     validate = is_graphical(c)
+                    case (6);     validate = is_punctuation(c)
+                    case (7);     validate = is_alphanum(c)
+                    case (8);     validate = is_alpha(c)
+                    case (9);     validate = is_upper(c)
+                    case (10);    validate = is_lower(c)
+                    case (11);    validate = is_digit(c)
+                    case (12);    validate = is_hex_digit(c)
+                    case default; validate = .false.
+                end select
+            end function validate
+    
+    end subroutine ascii_table
+
+    subroutine test_ascii_table(error)
+        type(error_type), allocatable, intent(out) :: error
+        logical :: arr(15, 12)
+        logical, parameter :: ascii_class_table(15,12) = transpose(reshape([ &
+        ! iscntrl  isprint  isspace  isblank  isgraph  ispunct  isalnum  isalpha  isupper  islower  isdigit  isxdigit
+        .true.,   .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., & ! 0–8
+        .true.,   .false., .true.,  .true.,  .false., .false., .false., .false., .false., .false., .false., .false., & ! 9
+        .true.,   .false., .true.,  .false., .false., .false., .false., .false., .false., .false., .false., .false., & ! 10–13
+        .true.,   .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., & ! 14–31
+        .false.,  .true.,  .true.,  .true.,  .false., .false., .false., .false., .false., .false., .false., .false., & ! 32 (space)
+        .false.,  .true.,  .false., .false., .true.,  .true.,  .false., .false., .false., .false., .false., .false., & ! 33–47
+        .false.,  .true.,  .false., .false., .true.,  .false., .true.,  .false., .false., .false., .true.,  .true.,  & ! 48–57
+        .false.,  .true.,  .false., .false., .true.,  .true.,  .false., .false., .false., .false., .false., .false., & ! 58–64
+        .false.,  .true.,  .false., .false., .true.,  .false., .true.,  .true.,  .true.,  .false., .false., .true.,  & ! 65–70
+        .false.,  .true.,  .false., .false., .true.,  .false., .true.,  .true.,  .true.,  .false., .false., .false., & ! 71–90
+        .false.,  .true.,  .false., .false., .true.,  .true.,  .false., .false., .false., .false., .false., .false., & ! 91–96
+        .false.,  .true.,  .false., .false., .true.,  .false., .true.,  .true.,  .false., .true.,  .false., .true.,  & ! 97–102
+        .false.,  .true.,  .false., .false., .true.,  .false., .true.,  .true.,  .false., .true.,  .false., .false., & ! 103–122
+        .false.,  .true.,  .false., .false., .true.,  .true.,  .false., .false., .false., .false., .false., .false., & ! 123–126
+        .true.,   .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false.  & ! 127
+        ], shape=[12,15]))
+
+        call ascii_table(arr)
+        call check(error, all(arr .eqv. ascii_class_table), "ascii table was not accurately generated")
+
     end subroutine test_ascii_table
 
     subroutine test_to_lower_string(error)
diff --git a/test/intrinsics/test_intrinsics.fypp b/test/intrinsics/test_intrinsics.fypp
@@ -246,6 +246,27 @@ subroutine test_dot_product(error)
         call check(error, all(err(:)<tolerance) , "complex dot_product is not accurate" )
         if (allocated(error)) return
     end block
+
+    block ! test for https://github.com/fortran-lang/stdlib/issues/1016
+        ${t}$ :: x(128), y(128)
+        real(${k}$) :: z(128,2)
+        real(${k}$), parameter :: tolerance = epsilon(1._${k}$)*100000
+        real(${k}$) :: err(2)
+        ${t}$ :: p(3)
+
+        call random_number(z)
+        x%re = z(:, 1); x%im = z(:, 2)
+        call random_number(z)
+        y%re = z(:, 1); y%im = z(:, 2)
+        
+        p(1) = dot_product(x,y) ! compiler intrinsic
+        p(2) = stdlib_dot_product_kahan(x,y) ! chunked Kahan dot_product
+        p(3) = stdlib_dot_product(x,y)       ! chunked dot_product
+        err(1:2) = sqrt((p(2:3)%re - p(1)%re)**2 + (p(2:3)%im - p(1)%im)**2)
+        
+        call check(error, all(err(:)<tolerance) , "complex dot_product does not conform to the standard" )
+        if (allocated(error)) return
+    end block
     #:endfor
 
 end subroutine
