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

103
scsh/scsh.scm
View File

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