fortran-lang · LKedward · Jul 28, 2021 · Jun 30, 2021 · Jun 30, 2021 · Jul 7, 2021
diff --git a/src/filesystem_utilities.c b/src/filesystem_utilities.c
@@ -0,0 +1,41 @@
+#include <sys/stat.h>
+#include <dirent.h>
+
+#ifdef __APPLE__
+DIR * opendir$INODE64( const char * dirName );
+struct dirent * readdir$INODE64( DIR * dir );
+#endif
+
+int c_is_dir(const char *path)
+{
+    struct stat m;
+    int r = stat(path, &m);
+    return r == 0 && S_ISDIR(m.st_mode);
+}
+
+const char *get_d_name(struct dirent *d)
+{
+    return (const char *) d->d_name;
+}
+
+
+
+DIR *c_opendir(const char *dirname){
+
+#ifdef __APPLE__
+    return opendir$INODE64(dirname);
+#else
+    return opendir(dirname);
+#endif
+
+}
+
+struct dirent *c_readdir(DIR *dirp){
+
+#ifdef __APPLE__
+    return readdir$INODE64(dirp);
+#else
+    return readdir(dirp);
+#endif
+
+}
diff --git a/src/fpm_environment.f90 b/src/fpm_environment.f90
@@ -40,14 +40,24 @@ integer function get_os_type() result(r)
         character(len=32) :: val
         integer           :: length, rc
         logical           :: file_exists
+        logical, save     :: first_run = .true.
+        integer, save     :: ret = OS_UNKNOWN
+        !omp threadprivate(ret, first_run)
 
+        if (.not. first_run) then
+            r = ret
+            return
+        end if
+
+        first_run = .false.
         r = OS_UNKNOWN
 
         ! Check environment variable `OS`.
         call get_environment_variable('OS', val, length, rc)
 
         if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then
             r = OS_WINDOWS
+            ret = r
             return
         end if
 
@@ -58,42 +68,49 @@ integer function get_os_type() result(r)
             ! Linux
             if (index(val, 'linux') > 0) then
                 r = OS_LINUX
+                ret = r
                 return
             end if
 
             ! macOS
             if (index(val, 'darwin') > 0) then
                 r = OS_MACOS
+                ret = r
                 return
             end if
 
             ! Windows, MSYS, MinGW, Git Bash
             if (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then
                 r = OS_WINDOWS
+                ret = r
                 return
             end if
 
             ! Cygwin
             if (index(val, 'cygwin') > 0) then
                 r = OS_CYGWIN
+                ret = r
                 return
             end if
 
             ! Solaris, OpenIndiana, ...
             if (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then
                 r = OS_SOLARIS
+                ret = r
                 return
             end if
 
             ! FreeBSD
             if (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then
                 r = OS_FREEBSD
+                ret = r
                 return
             end if
 
             ! OpenBSD
             if (index(val, 'OpenBSD') > 0 .or. index(val, 'openbsd') > 0) then
                 r = OS_OPENBSD
+                ret = r
                 return
             end if
         end if
@@ -103,6 +120,7 @@ integer function get_os_type() result(r)
 
         if (file_exists) then
             r = OS_LINUX
+            ret = r
             return
         end if
 
@@ -111,6 +129,7 @@ integer function get_os_type() result(r)
 
         if (file_exists) then
             r = OS_MACOS
+            ret = r
             return
         end if
 
@@ -119,6 +138,7 @@ integer function get_os_type() result(r)
 
         if (file_exists) then
             r = OS_FREEBSD
+            ret = r
             return
         end if
     end function get_os_type

diff --git a/src/fpm_filesystem.f90 → src/fpm_filesystem.F90 b/src/fpm_filesystem.f90 → src/fpm_filesystem.F90
@@ -7,6 +7,7 @@ module fpm_filesystem
                                OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD
     use fpm_environment, only: separator, get_env
     use fpm_strings, only: f_string, replace, string_t, split
+    use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer
     use fpm_error, only : fpm_stop
     implicit none
     private
@@ -17,6 +18,39 @@ module fpm_filesystem
 
     integer, parameter :: LINE_BUFFER_LEN = 1000
 
+#ifndef FPM_BOOTSTRAP
+    interface
+        function c_opendir(dir) result(r) bind(c, name="c_opendir")
+            import c_char, c_ptr
+            character(kind=c_char), intent(in) :: dir(*)
+            type(c_ptr) :: r
+        end function c_opendir
+
+        function c_readdir(dir) result(r) bind(c, name="c_readdir")
+            import c_ptr
+            type(c_ptr), intent(in), value :: dir
+            type(c_ptr) :: r
+        end function c_readdir
+
+        function c_closedir(dir) result(r) bind(c, name="closedir")
+            import c_ptr, c_int
+            type(c_ptr), intent(in), value :: dir
+            integer(kind=c_int) :: r
+        end function c_closedir
+
+        function c_get_d_name(dir) result(r) bind(c, name="get_d_name")
+            import c_ptr
+            type(c_ptr), intent(in), value :: dir
+            type(c_ptr) :: r
+        end function c_get_d_name
+
+        function c_is_dir(path) result(r) bind(c, name="c_is_dir")
+            import c_char, c_int
+            character(kind=c_char), intent(in) :: path(*)
+            integer(kind=c_int) :: r
+        end function c_is_dir
+    end interface
+#endif
 
 contains
 
@@ -226,13 +260,23 @@ function join_path(a1,a2,a3,a4,a5) result(path)
     character(len=*), intent(in), optional :: a3, a4, a5
     character(len=:), allocatable          :: path
     character(len=1)                       :: filesep
+    logical, save                          :: has_cache = .false.
+    character(len=1), save                 :: cache = '/'
+    !$omp threadprivate(has_cache, cache)
 
-    select case (get_os_type())
-        case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
-            filesep = '/'
-        case (OS_WINDOWS)
-            filesep = '\'
-    end select
+    if (has_cache) then
+        filesep = cache
+    else
+        select case (get_os_type())
+            case default
+                filesep = '/'
+            case (OS_WINDOWS)
+                filesep = '\'
+        end select
+
+        cache = filesep
+        has_cache = .true.
+    end if
 
     path = a1 // filesep // a2
 
@@ -311,7 +355,94 @@ subroutine mkdir(dir)
     end if
 end subroutine mkdir
 
+#ifndef FPM_BOOTSTRAP
+!> Get file & directory names in directory `dir` using iso_c_binding.
+!!
+!!  - File/directory names return are relative to cwd, ie. preprended with `dir`
+!!  - Includes files starting with `.` except current directory and parent directory
+!!
+recursive subroutine list_files(dir, files, recurse)
+    character(len=*), intent(in) :: dir
+    type(string_t), allocatable, intent(out) :: files(:)
+    logical, intent(in), optional :: recurse
+
+    integer :: i
+    type(string_t), allocatable :: dir_files(:)
+    type(string_t), allocatable :: sub_dir_files(:)
+
+    type(c_ptr) :: dir_handle
+    type(c_ptr) :: dir_entry_c
+    character(len=:,kind=c_char), allocatable :: fortran_name
+    character(len=:), allocatable :: string_fortran
+    integer, parameter :: N_MAX = 256
+    type(string_t) :: files_tmp(N_MAX)
+    integer(kind=c_int) :: r
+
+    if (c_is_dir(dir(1:len_trim(dir))//c_null_char) .eq. 0) then
+        allocate (files(0))
+        return
+    end if
+
+    dir_handle = c_opendir(dir(1:len_trim(dir))//c_null_char)
+    if (.not. c_associated(dir_handle)) then
+        print *, 'c_opendir() failed'
+        error stop
+    end if
+
+    i = 0
+    allocate(files(0))
 
+    do
+        dir_entry_c = c_readdir(dir_handle)
+        if (.not. c_associated(dir_entry_c)) then
+            exit
+        else
+            string_fortran = f_string(c_get_d_name(dir_entry_c))
+
+            if ((string_fortran .eq. '.' .or. string_fortran .eq. '..')) then
+                cycle
+            end if
+
+            i = i + 1
+
+            if (i .gt. N_MAX) then
+                files = [files, files_tmp]
                i = 1
+            end if
+
+            files_tmp(i)%s = join_path(dir, string_fortran)
+        end if
+    end do
+
+    r = c_closedir(dir_handle)
+
+    if (r .ne. 0) then
+        print *, 'c_closedir() failed'
+        error stop
+    end if
+
+    if (i .gt. 0) then
+        files = [files, files_tmp(1:i)]
+    end if
+
+    if (present(recurse)) then
+        if (recurse) then
+
+            allocate(sub_dir_files(0))
+
+            do i=1,size(files)
+                if (c_is_dir(files(i)%s//c_null_char) .ne. 0) then
+                    call list_files(files(i)%s, dir_files, recurse=.true.)
+                    sub_dir_files = [sub_dir_files, dir_files]
+                end if
+            end do
+
+            files = [files, sub_dir_files]
+        end if
+    end if
+end subroutine list_files
+
+#else
 !> Get file & directory names in directory `dir`.
 !!
 !!  - File/directory names return are relative to cwd, ie. preprended with `dir`
@@ -376,6 +507,8 @@ recursive subroutine list_files(dir, files, recurse)
 
 end subroutine list_files
 
+#endif
+
 
 !> test if pathname already exists
 logical function exists(filename) result(r)

diff --git a/src/fpm_strings.f90 b/src/fpm_strings.f90
@@ -31,6 +31,7 @@
 
 module fpm_strings
 use iso_fortran_env, only: int64
+use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer, c_size_t
 implicit none
 
 private
@@ -73,6 +74,10 @@ module fpm_strings
     module procedure new_string_t
 end interface string_t
 
+interface f_string
+    module procedure f_string, f_string_cptr, f_string_cptr_n
+end interface f_string
+
 contains
 
 !> test if a CHARACTER string ends with a specified suffix
@@ -128,6 +133,33 @@ function f_string(c_string)
 end function f_string
 
 
+!> return Fortran character variable when given a null-terminated c_ptr
+function f_string_cptr(cptr) result(s)
+    type(c_ptr), intent(in), value :: cptr
+    character(len=:,kind=c_char), allocatable :: s
+
+    interface
+        function c_strlen(s) result(r) bind(c, name="strlen")
+            import c_size_t, c_ptr
+            type(c_ptr), intent(in), value :: s
+            integer(kind=c_size_t) :: r
+        end function
+    end interface
+
+    s = f_string_cptr_n(cptr, c_strlen(cptr))
+end function
+
+!> return Fortran character variable when given a null-terminated c_ptr and its length
+function f_string_cptr_n(cptr, n) result(s)
+    type(c_ptr), intent(in), value :: cptr
+    integer(kind=c_size_t), intent(in) :: n
+    character(len=n,kind=c_char) :: s
+    character(len=n,kind=c_char), pointer :: sptr
+
+    call c_f_pointer(cptr, sptr)
+    s = sptr
+end function
+
 !> Hash a character(*) string of default kind
 pure function fnv_1a_char(input, seed) result(hash)
     character(*), intent(in) :: input