Preserve ports in forked child.
The use of NARROW had borked this.
This commit is contained in:
parent
d2783645ea
commit
37948e173d
|
@ -927,6 +927,21 @@
|
||||||
(not dont-narrow?)
|
(not dont-narrow?)
|
||||||
maybe-thunk)))
|
maybe-thunk)))
|
||||||
|
|
||||||
|
(define (preserve-ports thunk)
|
||||||
|
(let ((current-input (current-input-port))
|
||||||
|
(current-output (current-output-port))
|
||||||
|
(current-error (current-error-port)))
|
||||||
|
(lambda ()
|
||||||
|
(with-current-input-port*
|
||||||
|
current-input
|
||||||
|
(lambda ()
|
||||||
|
(with-current-output-port*
|
||||||
|
current-output
|
||||||
|
(lambda ()
|
||||||
|
(with-current-error-port*
|
||||||
|
current-error
|
||||||
|
thunk))))))))
|
||||||
|
|
||||||
(define (really-fork clear-interactive? narrow? maybe-thunk)
|
(define (really-fork clear-interactive? narrow? maybe-thunk)
|
||||||
(with-env-aligned* ; not neccessary here but doing it on exec
|
(with-env-aligned* ; not neccessary here but doing it on exec
|
||||||
; genereates no cache in the parent
|
; genereates no cache in the parent
|
||||||
|
@ -935,7 +950,8 @@
|
||||||
(maybe-narrow
|
(maybe-narrow
|
||||||
(if narrow?
|
(if narrow?
|
||||||
(lambda (thunk)
|
(lambda (thunk)
|
||||||
(narrow (preserve-thread-fluids thunk)
|
;; narrow loses the thread fluids and the dynamic environment
|
||||||
|
(narrow (preserve-ports (preserve-thread-fluids thunk))
|
||||||
'forking))
|
'forking))
|
||||||
(lambda (thunk) (thunk)))))
|
(lambda (thunk) (thunk)))))
|
||||||
(maybe-narrow
|
(maybe-narrow
|
||||||
|
|
Loading…
Reference in New Issue