-! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations io
-io.backend.windows io.pipes.windows.nt io.pathnames libc io.ports
-windows.types math windows.kernel32
-namespaces make io.launcher kernel sequences windows.errors
-splitting system threads init strings combinators
-io.backend accessors concurrency.flags io.files assocs
-io.files.private windows destructors specialized-arrays.ushort
-specialized-arrays.alien classes classes.struct ;
+io.backend.windows io.pipes.windows.nt io.pathnames libc
+io.ports windows.types math windows.kernel32 namespaces make
+io.launcher kernel sequences windows.errors splitting system
+threads init strings combinators io.backend accessors
+concurrency.flags io.files assocs io.files.private windows
+destructors classes classes.struct specialized-arrays
+debugger prettyprint ;
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: void*
IN: io.launcher.windows
TUPLE: CreateProcess-args
M: windows current-process-handle ( -- handle )
GetCurrentProcessId ;
+ERROR: launch-error process error ;
+
+M: launch-error error.
+ "Launching failed with error:" print
+ dup error>> error. nl
+ "Launch descriptor:" print nl
+ process>> . ;
+
M: windows run-process* ( process -- handle )
[
- current-directory get (normalize-path) cd
-
- dup make-CreateProcess-args
- tuck fill-redirection
- dup call-CreateProcess
- lpProcessInformation>>
- ] with-destructors ;
+ [
+ current-directory get absolute-path cd
+
+ dup make-CreateProcess-args
+ [ fill-redirection ] keep
+ dup call-CreateProcess
+ lpProcessInformation>>
+ ] with-destructors
+ ] [ launch-error ] recover ;
M: windows kill-process* ( handle -- )
hProcess>> 255 TerminateProcess win32-error=0/f ;
: exit-code ( process -- n )
hProcess>>
- 0 <ulong> [ GetExitCodeProcess ] keep *ulong
+ { DWORD } [ GetExitCodeProcess ] [ ] with-out-parameters
swap win32-error=0/f ;
: process-exited ( process -- )