From e6f78c50b27444c8c8faf88962af60134a32e2f0 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Sat, 3 Nov 2012 19:14:27 +0100
Subject: Support new process-fork form which can kill all other threads.  We
 still see some problems occurring

---
 scsh-process.scm   | 25 +++++++++++++------------
 scsh-process.setup | 13 ++++++++++++-
 tests/run.scm      | 17 ++++++++++++++++-
 3 files changed, 41 insertions(+), 14 deletions(-)

diff --git a/scsh-process.scm b/scsh-process.scm
index 7debdee..e53cbf3 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -8,7 +8,8 @@
 ;;
 ;; || wasn't changed, but it's really the zero-length symbol
 ;;
-;; BIG FAT WARNING: Don't mix this with threading, or Bad Things will happen
+;; WARNING: Don't mix with threading unless you're using
+;;          Chicken 4.8.1 rev 47b5be71 or later.
 ;;
 ;;; Copyright (c) 2012, Peter Bex
 ;; All rights reserved.
@@ -153,9 +154,8 @@
 (define (exec-path prog . args)
   (process-execute (maybe->string prog) (map maybe->string args)))
 
-;; TODO: continue-threads argument
-(define (fork/pipe #!optional thunk)
-  (fork/pipe+ '((1 2 0)) thunk))
+(define (fork/pipe #!optional thunk continue-threads?)
+  (fork/pipe+ '((1 2 0)) thunk continue-threads?))
 
 ;; Run a thunk and exit 0 after the thunk returns.
 ;; If an exception occurs, handle it and exit 1.
@@ -168,18 +168,22 @@
     (thunk)
     (exit 0)))
 
-(define (fork #!optional thunk)
-  (let ((pid (if thunk (process-fork thunk) (process-fork))))
+(define (fork #!optional thunk continue-threads?)
+  (let ((pid (cond-expand
+              (has-thread-killer
+               (process-fork thunk (not continue-threads?)))
+              (else ;; Ignore both args if thunk is #f, so #f won't be applied
+               (if thunk (process-fork thunk) (process-fork))))))
     (and (not (zero? pid)) (add-scsh-pending-process! pid))))
 
 (define %fork fork)
 
-(define (fork/pipe+ conns #!optional thunk)
+(define (fork/pipe+ conns #!optional thunk continue-threads?)
   ;; Blergh, this is silly overhead we don't really need
   (let* ((from-fds (map (lambda (x) (drop-right x 1)) conns))
          (to-fds (map last conns))
          (pipe-pairs (map (lambda _ (receive (create-pipe))) to-fds))
-         (proc (fork)))
+         (proc (fork #f continue-threads?)))
     (if (not proc)                      ; Child
         (begin
           (for-each (lambda (p from-fds-for-this-p)
@@ -373,10 +377,7 @@
                         (exec-epf (epf ?last-pf))))))))
        (pipe+ ?args ...)))
     ((_ (begin ?expr0 ...))
-     (begin (setup-redirection (= 0 (current-input-port)))
-            (setup-redirection (= 1 (current-output-port)))
-            (setup-redirection (= 2 (current-error-port)))
-            ?expr0 ...))
+     (begin (setup-redirection stdports) ?expr0 ...))
     ((_ (epf ?args ...))              ; This disambiguates redirection
      (exec-epf ?args ...))
     ((_ (?prog ?arg0 ...) ?redir0 ...)
diff --git a/scsh-process.setup b/scsh-process.setup
index 0dcea89..09fb10a 100644
--- a/scsh-process.setup
+++ b/scsh-process.setup
@@ -1,3 +1,14 @@
 ;; -*- Scheme -*-
 
-(standard-extension 'scsh-process "0.3.1")
+
+;; Assume people on old versions of 4.8.1 don't mind breakage (they're running git master!)
+(let ((features (if (version>=? (chicken-version) "4.8.1")
+                    '(-feature has-thread-killer)
+                    '())))
+  (compile -s -O3 scsh-process.scm ,@features -j scsh-process)
+  (compile -s -O3 scsh-process.import.scm))
+
+(install-extension
+  'scsh-process
+  '("scsh-process.so" "scsh-process.import.so")
+  `((version 0.3.2)))
diff --git a/tests/run.scm b/tests/run.scm
index ae12600..13313e5 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,7 +1,7 @@
 #;(include "../scsh-process.scm")
 (use scsh-process)
 
-(use test posix srfi-13)
+(use test posix srfi-13 srfi-18 (only setup-api chicken-version version>=?))
 
 (test-begin "scsh-process")
 
@@ -59,6 +59,21 @@
       (delete-file* tmpfile)))
 
   (test-group "Subprocesses"
+    (test "run/string with begin form"
+          "hi, there\n"
+          (run/string (pipe (begin (print "hi, there")) (cat))))
+    (when (version>=? (chicken-version) "4.8.1")
+      (let ((child? #f))
+        (thread-start! (lambda ()
+                         (thread-sleep! 0.5)
+                         (when child? (print "haihai"))))
+        (test "Simple 'begin' form with threading"
+              "hi, there\n"
+              (run/string (pipe (begin (set! child? #t)
+                                       (thread-sleep! 1)
+                                       (print "hi, there"))
+                                (cat))))))
+    
     (let ((outfile "outfile"))
       (test "Subprocess writing to a file"
             "hi, there\n"
-- 
cgit v1.2.3