1 ;;;; Windows API bindings not needed for cold initialization.
2 (in-package "SB-WIN32")
4 ;;;; CreateProcess and surrounding data structures provide a way to implement
5 ;;;; RUN-PROGRAM while using handles rather than file descriptors.
7 (define-alien-type process-information
8 (struct process-information
9 (process-handle handle)
10 (thread-handle handle)
14 (define-alien-type startup-info
17 (reserved1 system-string)
18 (desktop system-string)
26 (fill-attribute dword)
28 (show-window unsigned-short)
29 (reserved2 unsigned-short)
35 (defconstant +startf-use-std-handles+ #x100)
37 (define-alien-routine ("CreateProcessW" create-process) lispbool
38 (application-name system-string)
39 (command-line system-string)
40 (process-security-attributes (* t))
41 (thread-security-attributes (* t))
42 (inherit-handles-p lispbool)
43 (creation-flags dword)
45 (current-directory system-string)
47 (process-information (* t)))
49 (defun search-path (partial-name)
50 "Searh executable using the system path"
51 (with-alien ((pathname-buffer pathname-buffer))
52 (syscall (("SearchPath" t) dword
60 (values (decode-system-string pathname-buffer) result))
62 max_path (cast pathname-buffer (* char)) nil)))
64 (define-alien-routine ("GetExitCodeProcess" get-exit-code-process) int
65 (handle handle) (exit-code dword :out))
67 (define-alien-routine ("GetExitCodeThread" get-exit-code-thread) int
68 (handle handle) (exit-code dword :out))
70 (defun mswin-spawn (program argv stdin stdout stderr searchp envp waitp)
71 (declare (ignorable envp))
72 (let ((std-handles (multiple-value-list (get-std-handles)))
74 (flet ((maybe-std-handle (arg)
75 (let ((default (pop std-handles)))
76 (case arg (-1 default) (otherwise (setf inheritp t) arg)))))
77 (with-alien ((process-information process-information)
78 (startup-info startup-info))
79 (sb-kernel:system-area-ub8-fill
80 0 (alien-sap startup-info)
81 0 (alien-size startup-info :bytes))
82 (setf (slot startup-info 'cb) (alien-size startup-info :bytes)
83 (slot startup-info 'stdin) (maybe-std-handle stdin)
84 (slot startup-info 'stdout) (maybe-std-handle stdout)
85 (slot startup-info 'stderr) (maybe-std-handle stderr)
86 (slot startup-info 'reserved1) nil
87 (slot startup-info 'reserved2) 0
88 (slot startup-info 'reserved3) nil
89 (slot startup-info 'flags) (if inheritp +startf-use-std-handles+ 0))
91 ;; KLUDGE: pass null image file name when searchp is true.
92 ;; This way, file extension gets resolved by OS if omitted.
93 (if (create-process (if searchp nil program)
97 (alien-sap startup-info)
98 (alien-sap process-information))
99 (let ((child (slot process-information 'process-handle)))
100 (close-handle (slot process-information 'thread-handle))
102 (do () ((/= 1 (with-local-interrupts (wait-object-or-signal child)))
103 (multiple-value-bind (got code) (get-exit-code-process child)