169 lines
5.3 KiB
Scheme
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) ? s48_enter_fixnum(errno) : S48_FALSE)"
|
|
"" "")
|
|
|
|
;;; 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))
|