1995-10-13 23:34:21 -04:00
|
|
|
;;; Copyright (c) 1993 by Olin Shivers.
|
2001-03-10 22:47:00 -05:00
|
|
|
;;; Job control code. See file COPYING.
|
1995-10-13 23:34:21 -04:00
|
|
|
|
|
|
|
|
;;; Fork off a process that runs in its own process group. The process
|
|
|
|
|
;;; is (1) placed in its own process group and (2) suspended before
|
|
|
|
|
;;; the process's actual work code is executed, and before FORK-JOB
|
|
|
|
|
;;; returns to the parent. The next time the job is resumed, it will
|
|
|
|
|
;;; begin its actual work.
|
|
|
|
|
|
|
|
|
|
(define (fork-job . maybe-thunk)
|
|
|
|
|
(let ((child (fork)))
|
|
|
|
|
|
|
|
|
|
(cond (child
|
|
|
|
|
;; PARENT -- wait for child to stop and then set its proc group.
|
|
|
|
|
(let ((status (wait child wait/stopped-children)))
|
|
|
|
|
(if (not (status:stop-sig status)) ; Make sure it didn't die.
|
|
|
|
|
(error "premature job death" status))) ; error call right?
|
|
|
|
|
(set-process-group child child))
|
|
|
|
|
|
|
|
|
|
;; CHILD -- suspend until we are put in our own proc group.
|
|
|
|
|
;; The test&suspend isn't atomic; the parent needs to do things
|
|
|
|
|
;; in the right order to make this win.
|
|
|
|
|
(else (let lp ()
|
|
|
|
|
(signal-process 0 signal/stop)
|
|
|
|
|
(if (not (= (pid) (process-group))) (lp)))
|
|
|
|
|
|
|
|
|
|
(if (pair? maybe-thunk)
|
|
|
|
|
(call-terminally (car maybe-thunk)))))
|
|
|
|
|
|
|
|
|
|
child))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Foreground a suspended or running background job.
|
|
|
|
|
|
|
|
|
|
(define (resume-job proc-group)
|
|
|
|
|
(set-terminal-proc-group 0 proc-group) ; Give tty to job.
|
|
|
|
|
(signal-process-group proc-group signal/cont)
|
|
|
|
|
(let ((status (wait proc-group wait/stopped-children)))
|
|
|
|
|
(set-terminal-proc-group 0 (process-group)) ; Take tty back.
|
|
|
|
|
status))
|
|
|
|
|
|
|
|
|
|
;;; What if stdin (fd 0) isn't a tty? Need a (control-tty)
|
|
|
|
|
;;; or (control-tty-fdes) procedure.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Background a suspended job.
|
|
|
|
|
|
|
|
|
|
(define (background-job proc-group)
|
|
|
|
|
(signal-process-group proc-group signal/cont)
|
|
|
|
|
proc-group)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define-simple-syntax (run . epf)
|
|
|
|
|
(resume-job (fork-job (lambda () (exec-epf . epf)))))
|
|
|
|
|
|
|
|
|
|
(define-simple-syntax (& . epf)
|
|
|
|
|
(background-job (fork-job (lambda () (exec-epf . epf)))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Need repl loop that manages some kind of a job table,
|
|
|
|
|
;;; and grabs the terminal back after running a job.
|
|
|
|
|
;;; Should I define a WAIT-JOB procedure?
|
|
|
|
|
;;; Need a (CONTROL-TTY) procedure.
|
|
|
|
|
|
