scsh-0.6/scsh/jcontrol2.scm

169 lines
5.3 KiB
Scheme

;;; The signal-handling code in the last half of this file is obsolete. 8/23/96
;;; Copyright (c) 1993 by Olin Shivers.
;;; Job control code.
(foreign-source
"#include <sys/signal.h>"
"#include <sys/types.h>"
"#include <unistd.h>"
""
"extern int errno;"
""
"#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
"" "")
;;; Fork off a process that runs in its own process group. The process is
;;; placed in its own process group before the process's actual work code is
;;; executed. We block ^Z's until we've got the child into its own proc group.
(define (fork-job . maybe-thunk)
(flush-all-ports)
((with-blocked-interrupts (bitwise-ior (blocked-interrupts) ; Block ^Z.
(interrupt-set signal/tstp))
(cond ((%fork) => (lambda (child) (lambda () child))) ; Parent
(else ; Child
(set-process-group (pid)) ; Put ourselves in our own proc group.
(if (not (interrupt-handler signal/tstp)) ; If ignoring TSTP,
(set-interrupt-handler signal/tstp #t)) ; reset to default.
(set-batch-mode?! #t) ; Batch mode.
(lambda () (and (pair? maybe-thunk) ; Release ^Z & do it.
(call-terminally (car maybe-thunk)))))))))
;;; Foreground a suspended or running background job.
(define (foreground-job proc-group)
(let ((iport (current-input-port)))
(cond ((and (not (batch-mode?)) (is-control-tty? iport))
(dynamic-wind
(lambda () (set-tty-process-group iport proc-group))
(lambda ()
(signal-process-group proc-group signal/cont) ; You go;
(wait proc-group wait/stopped-children)) ; I'll wait.
(lambda ()
(with-blocked-interrupts
(bitwise-ior (blocked-interrupts)
(interrupt-set signal/ttou))
(set-tty-process-group iport (process-group))))))
;; Oops, not really doing job control -- just wait on the process.
(else (signal-process proc-group signal/cont) ; You go;
(wait proc-group wait/stopped-children))))) ; I'll wait.
;;; Background a suspended job.
(define (background-job proc-group)
(signal-process-group proc-group signal/cont))
(define-simple-syntax (run . epf)
(foreground-job (& . epf)))
(define-simple-syntax (& . epf)
(fork-job (lambda () (exec-epf . epf))))
;;; Need repl loop that manages some kind of a job table.
;;; Interactive startup must ignore ^Z.
(define *control-tty-fdes* #f)
(define (control-tty-fdes)
(or *control-tty-fdes*
(begin (set! *control-tty-fdes*
(with-errno-handler ((errno data) (else #f))
(open-fdes "/dev/tty" open/read)))
*control-tty-fdes*)))
(define (is-control-tty? fd/port)
(with-errno-handler ((errno data) (else #f)) ; False if you fail.
(tty-process-group fd/port))) ; Try it.
;;; Blocking interrupts
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (interrupt-set . interrupts)
(let lp ((ints interrupts) (ans 0))
(if (pair? ints)
(lp (cdr ints) (bitwise-ior ans (arithmetic-shift 1 (- (car ints) 1))))
ans)))
(define-simple-syntax (with-blocked-interrupts mask body ...)
(with-blocked-interrupts* mask (lambda () body ...)))
(define (with-blocked-interrupts* mask thunk)
(let ((old-mask #f))
(dynamic-wind
(lambda () (set! old-mask (set-blocked-interrupts mask)))
thunk
(lambda () (set-blocked-interrupts old-mask)))))
(define (set-blocked-interrupts mask)
(receive (hi-out lo-out)
(%set-blocked-interrupts (hi8 mask) (lo24 mask))
(compose-8/24 hi-out lo-out)))
(define (blocked-interrupts)
(call-with-values %blocked-interrupts compose-8/24))
(define-foreign %set-blocked-interrupts (set_procmask (fixnum hi)
(fixnum lo))
fixnum ; hi
fixnum) ; lo
(define-foreign %blocked-interrupts (get_procmask)
fixnum ; hi
fixnum) ; lo
;;; Get/Set interrupt handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; I'm punting the MASK value for now.
;;; I'm also punting returning real Scheme handlers for now.
(define (set-interrupt-handler interrupt handler)
(receive (handler flags) ; Should be (handler mask flags).
(%set-interrupt-handler interrupt handler 0)
handler))
(define (interrupt-handler interrupt)
(receive (handler flags) (%interrupt-handler interrupt)
handler))
(define (%interrupt-handler interrupt)
(receive (err handler flags) (%%interrupt-handler interrupt)
(if err (errno-error err interrupt-handler interrupt)
(process-interrupt-handler-retvals handler flags))))
;;; (%set-interrupt-handler interrupt handler [mask flags]) -> [handler mask flags]
;;; Except no MASK for now.
(define (%set-interrupt-handler interrupt handler . args)
(let-optionals args ((flags 0))
(receive (err handler flags)
(%%set-interrupt-handler interrupt handler flags)
(if err
(errno-error err %set-interrupt-handler interrupt handler flags)
(process-interrupt-handler-retvals handler flags)))))
(define-foreign %%set-interrupt-handler (set_int_handler (fixnum signal)
(desc handler)
(fixnum flags))
desc ; #f or errno
desc ; handler
fixnum) ; flags
(define-foreign %%interrupt-handler (get_int_handler (fixnum signal))
desc ; #f or errno
desc ; handler
fixnum) ; flags
(define (process-interrupt-handler-retvals handler flags)
(values (if (integer? handler)
(error "We don't do Scheme handlers yet.")
handler)
flags))