>From d4de7eb646e57e8c2d2e3d3649cf1a3ec1b65cd8 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Thu, 23 May 2013 21:15:19 +0200
Subject: [PATCH] Kill other threads when starting a process, and exit even
 when an exception occurs (reported by Bryan Vicknair, analysis by Evan
 Hanson)

---
 NEWS          |  3 +++
 posixunix.scm | 32 ++++++++++++++++++--------------
 2 files changed, 21 insertions(+), 14 deletions(-)

diff --git a/NEWS b/NEWS
index be9d098..c08ca60 100644
--- a/NEWS
+++ b/NEWS
@@ -32,6 +32,9 @@
      (thanks to Florian Zumbiehl)
   - posix: memory-mapped file support for Windows (thanks to "rivo")
   - posix: find-file's test argument now also accepts SRE forms.
+  - posix: process, process* and process-run now properly kill other threads
+     and cause the process to exit with status 1 if running the process fails
+     (thanks to Evan Hanson and Bryan Vicknair)
 
 - Runtime system
   - Special events in poll() are now handled, avoiding hangs in threaded apps.
diff --git a/posixunix.scm b/posixunix.scm
index a2776da..7d8dcaf 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1734,12 +1734,14 @@ EOF
 	(when (fx= -1 pid) 
 	  (posix-error #:process-error 'process-fork "cannot create child process"))
 	(if (and thunk (zero? pid))
-	    ((if killothers
-		 ##sys#kill-other-threads
-		 (lambda (thunk) (thunk)))
-	     (lambda ()
-	       (thunk)
-	       ((foreign-lambda void "_exit" int) 0) ))
+	    (handle-exceptions exn
+		((foreign-lambda void "_exit" int) 1)
+		((if killothers
+		     ##sys#kill-other-threads
+		     (lambda (thunk) (thunk)))
+		 (lambda ()
+		   (thunk)
+		   ((foreign-lambda void "_exit" int) 0) )))
 	    pid)))))
 
 (define process-execute
@@ -1816,13 +1818,14 @@ EOF
   (list "-c" cmdlin) )
 
 (define process-run
-  (lambda (f . args)
-    (let ([args (if (pair? args) (car args) #f)]
-	  [pid (process-fork)] )
-      (cond [(not (eq? 0 pid)) pid]
-	    [args (process-execute f args)]
-	    [else
-	     (process-execute (##sys#shell-command) (##sys#shell-command-arguments f)) ] ) ) ) )
+  (lambda (f #!optional args)
+    (process-fork
+     (lambda ()
+       (if args
+           (process-execute f args)
+           (process-execute (##sys#shell-command)
+                            (##sys#shell-command-arguments f)) ))
+     #t)  ) )
 
 ;;; Run subprocess connected with pipes:
 
@@ -1893,7 +1896,8 @@ EOF
                         (connect-child loc opipe stdinf fileno/stdin)
                         (connect-child loc (swapped-ends ipipe) stdoutf fileno/stdout)
                         (connect-child loc (swapped-ends epipe) stderrf fileno/stderr)
-                        (process-execute cmd args env)))) ) ) )]
+                        (process-execute cmd args env))
+                      #t)) ) ) )]
           [input-port
             (lambda (loc pid cmd pipe stdf stdfd on-close)
               (and-let* ([fd (connect-parent loc pipe stdf stdfd)])
-- 
1.8.2.3