summaryrefslogtreecommitdiff
path: root/scsh-process.scm
diff options
context:
space:
mode:
Diffstat (limited to 'scsh-process.scm')
-rw-r--r--scsh-process.scm25
1 files changed, 13 insertions, 12 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 ...)