scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

+ Fixed small bug in fork: command level wasn't resumed in the no-thunk case. 

+ Optional continue-threads argument for fork/pipe and fork/pipe+
This commit is contained in:
mainzelm 2002-04-21 16:29:16 +00:00
parent 0741f2df4d
commit 8cb11125ae
1 changed files with 55 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
scsh/scsh.scm
View File

@ -22,38 +22,42 @@
;;; the parent's stdin to the child's stdout. This function side-effects ;;; the parent's stdin to the child's stdout. This function side-effects
;;; the parent by changing his stdin. ;;; the parent by changing his stdin.
(define (fork/pipe . maybe-thunk) (define (fork/pipe . stuff)
(really-fork/pipe fork maybe-thunk)) (really-fork/pipe fork stuff))
(define (%fork/pipe . maybe-thunk) (define (%fork/pipe . stuff)
(really-fork/pipe %fork maybe-thunk)) (really-fork/pipe %fork stuff))
;;; Common code for FORK/PIPE and %FORK/PIPE. ;;; Common code for FORK/PIPE and %FORK/PIPE.
(define (really-fork/pipe forker maybe-thunk) (define (really-fork/pipe forker rest)
(let-optionals rest ((maybe-thunk #f)
(no-new-command-level? #f))
(receive (r w) (pipe) (receive (r w) (pipe)
(let ((proc (forker))) (let ((proc (forker #f no-new-command-level?)))
(cond (proc ; Parent (cond (proc ; Parent
(close w) (close w)
(move->fdes r 0)) (move->fdes r 0))
(else ; Child (else ; Child
(close r) (close r)
(move->fdes w 1) (move->fdes w 1)
(if (pair? maybe-thunk) (if maybe-thunk
(call-terminally (car maybe-thunk))))) (call-terminally maybe-thunk))))
proc))) proc))))
;;; FORK/PIPE with a connection list. ;;; FORK/PIPE with a connection list.
;;; (FORK/PIPE . m-t) = (apply fork/pipe+ '((1 0)) m-t) ;;; (FORK/PIPE . m-t) = (apply fork/pipe+ '((1 0)) m-t)
(define (%fork/pipe+ conns . maybe-thunk) (define (%fork/pipe+ conns . stuff)
(really-fork/pipe+ %fork conns maybe-thunk)) (really-fork/pipe+ %fork conns stuff))
(define (fork/pipe+ conns . maybe-thunk) (define (fork/pipe+ conns . stuff)
(really-fork/pipe+ fork conns maybe-thunk)) (really-fork/pipe+ fork conns stuff))
;;; Common code. ;;; Common code.
(define (really-fork/pipe+ forker conns maybe-thunk) (define (really-fork/pipe+ forker conns rest)
(let-optionals rest ((maybe-thunk #f)
(no-new-command-level? #f))
(let* ((pipes (map (lambda (conn) (call-with-values pipe cons)) (let* ((pipes (map (lambda (conn) (call-with-values pipe cons))
conns)) conns))
(rev-conns (map reverse conns)) (rev-conns (map reverse conns))
@ -61,7 +65,7 @@
rev-conns)) rev-conns))
(tos (map car rev-conns))) (tos (map car rev-conns)))
(let ((proc (forker))) (let ((proc (forker #f no-new-command-level?)))
(cond (proc ; Parent (cond (proc ; Parent
(for-each (lambda (to r/w) (for-each (lambda (to r/w)
(let ((w (cdr r/w)) (let ((w (cdr r/w))
@ -80,7 +84,7 @@
froms pipes) froms pipes)
(if (pair? maybe-thunk) (if (pair? maybe-thunk)
(call-terminally (car maybe-thunk))))) (call-terminally (car maybe-thunk)))))
proc))) proc))))
(define (tail-pipe a b) (define (tail-pipe a b)
(fork/pipe a) (fork/pipe a)
@ -924,7 +928,7 @@
(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
(lambda () (lambda ()
(let ((proc 'uninitialized) (let ((proc #f)
(maybe-push (maybe-push
(if new-command-level? (if new-command-level?
(lambda (thunk) (lambda (thunk)
@ -951,7 +955,10 @@
(if (and (session-started?) clear-interactive?) (if (and (session-started?) clear-interactive?)
(set-batch-mode?! #t)) ; Children are non-interactive. (set-batch-mode?! #t)) ; Children are non-interactive.
(if maybe-thunk (if maybe-thunk
(call-terminally maybe-thunk))) (call-terminally maybe-thunk)
(if new-command-level?
(proceed-with-command-level
(cadr (command-levels))))))
;; Parent ;; Parent
(begin (begin
(set! proc (new-child-proc pid)) (set! proc (new-child-proc pid))