+;;;; Windows API bindings not needed for cold initialization.
+(in-package "SB-WIN32")
+\f
+;;;; CreateProcess and surrounding data structures provide a way to implement
+;;;; RUN-PROGRAM while using handles rather than file descriptors.
+
+(define-alien-type process-information
+ (struct process-information
+ (process-handle handle)
+ (thread-handle handle)
+ (process-id dword)
+ (thread-id dword)))
+
+(define-alien-type startup-info
+ (struct startup-info
+ (cb dword)
+ (reserved1 system-string)
+ (desktop system-string)
+ (title system-string)
+ (x dword)
+ (y dword)
+ (x-size dword)
+ (y-size dword)
+ (x-chars dword)
+ (y-chars dword)
+ (fill-attribute dword)
+ (flags dword)
+ (show-window unsigned-short)
+ (reserved2 unsigned-short)
+ (reserved3 (* t))
+ (stdin handle)
+ (stdout handle)
+ (stderr handle)))
+
+(defconstant +startf-use-std-handles+ #x100)
+
+(define-alien-routine ("CreateProcessW" create-process) lispbool
+ (application-name system-string)
+ (command-line system-string)
+ (process-security-attributes (* t))
+ (thread-security-attributes (* t))
+ (inherit-handles-p lispbool)
+ (creation-flags dword)
+ (environment (* t))
+ (current-directory system-string)
+ (startup-info (* t))
+ (process-information (* t)))
+
+(defun search-path (partial-name)
+ "Searh executable using the system path"
+ (with-alien ((pathname-buffer pathname-buffer))
+ (syscall (("SearchPath" t) dword
+ system-string
+ system-string
+ system-string
+ dword
+ (* t)
+ (* t))
+ (and (plusp result)
+ (values (decode-system-string pathname-buffer) result))
+ nil partial-name nil
+ max_path (cast pathname-buffer (* char)) nil)))
+
+(define-alien-routine ("GetExitCodeProcess" get-exit-code-process) int
+ (handle handle) (exit-code dword :out))
+
+(define-alien-routine ("GetExitCodeThread" get-exit-code-thread) int
+ (handle handle) (exit-code dword :out))
+
+(defun mswin-spawn (program argv stdin stdout stderr searchp envp waitp)
+ (declare (ignorable envp))
+ (let ((std-handles (multiple-value-list (get-std-handles)))
+ (inheritp nil))
+ (flet ((maybe-std-handle (arg)
+ (let ((default (pop std-handles)))
+ (case arg (-1 default) (otherwise (setf inheritp t) arg)))))
+ (with-alien ((process-information process-information)
+ (startup-info startup-info))
+ (sb-kernel:system-area-ub8-fill
+ 0 (alien-sap startup-info)
+ 0 (alien-size startup-info :bytes))
+ (setf (slot startup-info 'cb) (alien-size startup-info :bytes)
+ (slot startup-info 'stdin) (maybe-std-handle stdin)
+ (slot startup-info 'stdout) (maybe-std-handle stdout)
+ (slot startup-info 'stderr) (maybe-std-handle stderr)
+ (slot startup-info 'reserved1) nil
+ (slot startup-info 'reserved2) 0
+ (slot startup-info 'reserved3) nil
+ (slot startup-info 'flags) (if inheritp +startf-use-std-handles+ 0))
+ (without-interrupts
+ ;; KLUDGE: pass null image file name when searchp is true.
+ ;; This way, file extension gets resolved by OS if omitted.
+ (if (create-process (if searchp nil program)
+ argv
+ nil nil
+ inheritp 0 nil nil
+ (alien-sap startup-info)
+ (alien-sap process-information))
+ (let ((child (slot process-information 'process-handle)))
+ (close-handle (slot process-information 'thread-handle))
+ (if waitp
+ (do () ((/= 1 (with-local-interrupts (wait-object-or-signal child)))
+ (multiple-value-bind (got code) (get-exit-code-process child)
+ (if got code -1))))
+ child))
+ -2))))))