feat: exec Fortran compiles via argv (posix_spawn/CreateProcess)

src/filesystem_utilities.c

@@ -1,6 +1,24 @@
 #include <sys/stat.h>
 #include <dirent.h>
 
+#ifndef _WIN32
+#include <errno.h>
+#include <fcntl.h>
+#include <spawn.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/wait.h>
+#include <unistd.h>
+
+extern char **environ;
+#endif
+
+#ifdef _WIN32
+#include <windows.h>
+#include <stdlib.h>
+#include <string.h>
+#endif
+
 #if defined(__APPLE__) && !defined(__aarch64__) && !defined(__ppc__) && !defined(__i386__)
 DIR * opendir$INODE64( const char * dirName );
 struct dirent * readdir$INODE64( DIR * dir );
@@ -29,3 +47,218 @@ struct dirent *c_readdir(DIR *dirp)
 {
     return readdir(dirp);
 }
+
+#ifdef _WIN32
+/* Quote one argv token using the CommandLineToArgvW rules so that
+   CreateProcess reconstructs the exact token. Caller frees the result. */
+static char *win_quote_arg(const char *arg)
+{
+    size_t len = strlen(arg);
+    size_t i;
+    int needs = (len == 0);
+    char *out;
+    char *q;
+
+    for (i = 0; i < len; ++i) {
+        char c = arg[i];
+        if (c == ' ' || c == '\t' || c == '\n' || c == '\v' || c == '"') {
+            needs = 1;
+            break;
+        }
+    }
+
+    if (!needs) {
+        out = (char *)malloc(len + 1);
+        if (out) memcpy(out, arg, len + 1);
+        return out;
+    }
+
+    out = (char *)malloc(2 * len + 3);
+    if (!out) return NULL;
+    q = out;
+    *q++ = '"';
+    for (i = 0; i < len;) {
+        size_t nbs = 0;
+        size_t k;
+        while (i < len && arg[i] == '\\') { ++nbs; ++i; }
+        if (i == len) {
+            for (k = 0; k < 2 * nbs; ++k) *q++ = '\\';
+            break;
+        } else if (arg[i] == '"') {
+            for (k = 0; k < 2 * nbs + 1; ++k) *q++ = '\\';
+            *q++ = '"';
+            ++i;
+        } else {
+            for (k = 0; k < nbs; ++k) *q++ = '\\';
+            *q++ = arg[i++];
+        }
+    }
+    *q++ = '"';
+    *q = '\0';
+    return out;
+}
+#endif
+
+int c_run_argv(const char *joined, int argc, const char *redirect)
+{
+#ifdef _WIN32
+    const char *p = joined;
+    int i;
+    int use_redirect = redirect != NULL && redirect[0] != '\0';
+    const char **argv = NULL;
+    char *cmd = NULL;
+    size_t cap = 1, n = 0;
+    char apppath[MAX_PATH];
+    char *appname = NULL;
+    DWORD found;
+    HANDLE hout = INVALID_HANDLE_VALUE;
+    SECURITY_ATTRIBUTES sa;
+    STARTUPINFOA si;
+    PROCESS_INFORMATION pi;
+    BOOL ok;
+    int result;
+
+    if (argc < 1) return 0;
+
+    argv = (const char **)calloc((size_t)argc + 1, sizeof(char *));
+    if (argv == NULL) return -1;
+    for (i = 0; i < argc; ++i) {
+        argv[i] = p;
+        p += strlen(p) + 1;
+    }
+
+    /* Reassemble a properly quoted command line for CreateProcess. */
+    cmd = (char *)malloc(cap);
+    if (cmd == NULL) { free((void *)argv); return -1; }
+    cmd[0] = '\0';
+    for (i = 0; i < argc; ++i) {
+        char *qa = win_quote_arg(argv[i]);
+        size_t ql;
+        size_t need;
+        if (qa == NULL) { free(cmd); free((void *)argv); return -1; }
+        ql = strlen(qa);
+        need = n + ql + 2;
+        if (need > cap) {
+            char *t;
+            cap = need * 2;
+            t = (char *)realloc(cmd, cap);
+            if (t == NULL) { free(qa); free(cmd); free((void *)argv); return -1; }
+            cmd = t;
+        }
+        if (i > 0) cmd[n++] = ' ';
+        memcpy(cmd + n, qa, ql);
+        n += ql;
+        cmd[n] = '\0';
+        free(qa);
+    }
+
+    /* Resolve the program through PATH with a default .exe extension. */
+    found = SearchPathA(NULL, argv[0], ".exe", MAX_PATH, apppath, NULL);
+    if (found > 0 && found < MAX_PATH) appname = apppath;
+
+    ZeroMemory(&si, sizeof(si));
+    si.cb = sizeof(si);
+    ZeroMemory(&pi, sizeof(pi));
+
+    /* Only override the child's std handles when redirecting. Setting
+       STARTF_USESTDHANDLES with the (often non-inheritable) console handles
+       can strip the child's console, so leave them alone otherwise and let
+       the child inherit the parent console normally. */
+    if (use_redirect) {
+        ZeroMemory(&sa, sizeof(sa));
+        sa.nLength = sizeof(sa);
+        sa.bInheritHandle = TRUE;
+        hout = CreateFileA(redirect, GENERIC_WRITE, FILE_SHARE_READ, &sa,
+                           CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
+        if (hout == INVALID_HANDLE_VALUE) { free(cmd); free((void *)argv); return -1; }
+        si.dwFlags |= STARTF_USESTDHANDLES;
+        si.hStdInput = GetStdHandle(STD_INPUT_HANDLE);
+        si.hStdOutput = hout;
+        si.hStdError = hout;
+    }
+
+    ok = CreateProcessA(appname, cmd, NULL, NULL, use_redirect, 0, NULL, NULL, &si, &pi);
+    if (!ok) {
+        result = -1;
+    } else {
+        DWORD code = 1;
+        WaitForSingleObject(pi.hProcess, INFINITE);
+        GetExitCodeProcess(pi.hProcess, &code);
+        CloseHandle(pi.hProcess);
+        CloseHandle(pi.hThread);
+        /* Keep a real (possibly high-bit) exit code positive so the caller
+           does not mistake it for the stat < 0 spawn-failure sentinel. */
+        result = (code > 0x7fffffff) ? 1 : (int)code;
+    }
+
+    if (hout != INVALID_HANDLE_VALUE) CloseHandle(hout);
+    free(cmd);
+    free((void *)argv);
+    return result;
+#else
+    char **argv = NULL;
+    const char *p = joined;
+    pid_t pid;
+    int spawn_status;
+    int wait_status;
+    int i;
+    int use_redirect = redirect != NULL && redirect[0] != '\0';
+    posix_spawn_file_actions_t actions;
+    posix_spawn_file_actions_t *actions_ptr = NULL;
+
+    if (argc < 1) {
+        return 0;
+    }
+
+    argv = calloc((size_t)argc + 1, sizeof(char *));
+    if (argv == NULL) {
+        return -1;
+    }
+
+    for (i = 0; i < argc; ++i) {
+        argv[i] = (char *)p;
+        p += strlen(p) + 1;
+    }
+
+    if (use_redirect) {
+        if (posix_spawn_file_actions_init(&actions) != 0) {
+            free(argv);
+            return -1;
+        }
+        actions_ptr = &actions;
+        if (posix_spawn_file_actions_addopen(&actions, STDOUT_FILENO, redirect,
+                                             O_WRONLY | O_CREAT | O_TRUNC, 0666) != 0 ||
+            posix_spawn_file_actions_adddup2(&actions, STDOUT_FILENO, STDERR_FILENO) != 0) {
+            posix_spawn_file_actions_destroy(&actions);
+            free(argv);
+            return -1;
+        }
+    }
+
+    spawn_status = posix_spawnp(&pid, argv[0], actions_ptr, NULL, argv, environ);
+    if (use_redirect) {
+        posix_spawn_file_actions_destroy(&actions);
+    }
+    free(argv);
+
+    if (spawn_status != 0) {
+        return spawn_status;
+    }
+
+    do {
+        spawn_status = waitpid(pid, &wait_status, 0);
+    } while (spawn_status < 0 && errno == EINTR);
+
+    if (spawn_status < 0) {
+        return -1;
+    }
+
+    if (WIFEXITED(wait_status)) {
+        return WEXITSTATUS(wait_status);
+    }
+    if (WIFSIGNALED(wait_status)) {
+        return 128 + WTERMSIG(wait_status);
+    }
+    return -1;
+#endif
+}

src/fpm_compiler.F90

@@ -38,9 +38,10 @@ module fpm_compiler
         OS_FREEBSD, &
         OS_OPENBSD, &
         OS_UNKNOWN, &
+        os_is_unix, &
         library_filename
 use fpm_filesystem, only: join_path, basename, get_temp_filename, delete_file, unix_path, &
-    & getline, run
+    & getline, run, run_argv
 use fpm_strings, only: split, string_cat, string_t, str_ends_with, str_begins_with_str, &
     & string_array_contains, lower, add_strings
 use fpm_error, only: error_t, fatal_error, fpm_stop
@@ -1427,8 +1428,9 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry
     logical, optional, intent(in) :: dry_run
 
     character(len=:), allocatable :: command
+    type(string_t), allocatable :: argv(:)
     type(error_t), allocatable :: error
-    logical :: mock
+    logical :: mock, tokenized
 
     ! Initialize intent(out) status so the mock path with no table returns
     ! a defined value.
@@ -1438,12 +1440,32 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry
     mock = .false.
     if (present(dry_run)) mock = dry_run
 
-    ! Set command
+    ! Set command (shell fallback string) and build the argv token list. The
+    ! command is split with the OS-native lexer (POSIX on Unix, Windows rules
+    ! otherwise) so quoting and backslash paths survive on both platforms.
     command = self%fc // " -c " // input // " " // args // " -o " // output
 
+    tokenized = .true.
+    call split_append(argv, self%fc, .false., .false., tokenized)
+    if (tokenized) then
+        call add_strings(argv, string_t("-c"))
+        call add_strings(argv, string_t(input))
+    end if
+    if (tokenized .and. len_trim(args) > 0) then
+        call split_append(argv, args, .true., .true., tokenized)
+    end if
+    if (tokenized) then
+        call add_strings(argv, string_t("-o"))
+        call add_strings(argv, string_t(output))
+    end if
+
     ! Execute command
     if (.not.mock) then
-       call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat)
+       if (tokenized) then
+          call run_argv(argv, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat)
+       else
+          call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat)
+       end if
        if (stat/=0) return
     endif
 
@@ -1453,6 +1475,60 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry
         stat = merge(-1,0,allocated(error))
     endif
 
+contains
+
+    !> Split a command fragment into argv tokens with the OS-native lexer and
+    !> append them to argv. fortran-shlex is not reentrant, so the split runs
+    !> in a critical region. join_spaced/keep_quotes apply to the POSIX lexer;
+    !> the Windows lexer already returns final argv tokens.
+    subroutine split_append(argv, str, join_spaced, keep_quotes, ok)
+        type(string_t), allocatable, intent(inout) :: argv(:)
+        character(len=*), intent(in) :: str
+        logical, intent(in) :: join_spaced, keep_quotes
+        logical, intent(inout) :: ok
+
+        character(len=:), allocatable :: parts(:)
+        integer :: k
+
+        if (.not.ok) return
+
+        !$omp critical(fpm_shlex_split)
+        if (os_is_unix()) then
+            parts = sh_split(str, join_spaced=join_spaced, keep_quotes=keep_quotes, success=ok)
+        else
+            parts = ms_split(str, success=ok)
+        end if
+        !$omp end critical(fpm_shlex_split)
+        if (.not.ok) return
+
+        do k = 1, size(parts)
+            if (len_trim(parts(k)) == 0) cycle
+            if (os_is_unix()) then
+                call add_strings(argv, string_t(clean_shlex_token(parts(k))))
+            else
+                call add_strings(argv, string_t(trim(parts(k))))
+            end if
+        end do
+    end subroutine split_append
+
+    function clean_shlex_token(token) result(clean)
+        character(len=*), intent(in) :: token
+        character(len=:), allocatable :: clean
+
+        integer :: j
+
+        clean = ""
+        do j = 1, len_trim(token)
+            select case (token(j:j))
+            case ("'", '"')
+                cycle
+            case default
+                clean = clean//token(j:j)
+            end select
+        end do
+        clean = trim(adjustl(clean))
+    end function clean_shlex_token
+
 end subroutine compile_fortran