removed obsolete files/code for jcontrol and signal sets

This commit is contained in:
mainzelm 2000-12-18 15:45:46 +00:00
parent 747dfe20df
commit 6c136b907d
9 changed files with 0 additions and 485 deletions

View File

@ -1,10 +0,0 @@
/* Convert between a lo24/hi integer-pair bitset and a sigset_t value.
** These macros are OS-dependent, and must be defined per-OS.
*/
#define make_sigset(maskp, hi, lo) ((maskp)->losigs=((hi)<<24)|(lo))
/* Not a procedure: */
#define split_sigset(mask, hip, lop) \
((*(hip)=(mask.losigs>>24)&0xff), \
(*(lop)=(mask.losigs&0xffffff)))

View File

@ -1,19 +0,0 @@
/* Convert between a lo24/hi integer-pair bitset and a sigset_t value.
** These macros are OS-dependent, and must be defined per-OS.
*/
#include <sys/param.h>
#if defined __FreeBSD_version && __FreeBSD_version > 400000
#define make_sigset(maskp, hi, lo)(*maskp.__bits[0] = ((hi)<<24)|(lo))
/* Not a procedure: */
#define split_sigset(mask, hip, lop) \
((*(hip)=(mask.__bits[0]>>24)&0xff), \
(*(lop)=(mask.__bits[0]&0xffffff)))
#else
#define make_sigset(maskp, hi, lo) (*maskp=((hi)<<24)|(lo))
/* Not a procedure: */
#define split_sigset(mask, hip, lop) \
((*(hip)=(mask>>24)&0xff), \
(*(lop)=(mask&0xffffff)))
#endif

View File

@ -1,64 +0,0 @@
;;; Copyright (c) 1993 by Olin Shivers.
;;; Job control code.
;;; 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.

View File

@ -1,97 +0,0 @@
/* This code is all obsolete & should be thrown away. 8/23/96 Olin. */
#include <unistd.h>
#include <sys/types.h>
#include <signal.h>
#include "cstuff.h"
extern int errno;
/* Hack the blocked-signal mask.
*******************************************************************************
*/
#include "machine/sigset.h"
int set_procmask(int hi, int lo, int *old_lo_p)
{
sigset_t mask, old_mask;
int old_hi;
make_sigset(&mask, hi, lo);
sigprocmask(SIG_SETMASK, &mask, &old_mask);
split_sigset(old_mask, &old_hi, old_lo_p);
return old_hi;
}
int get_procmask(int *old_lo_p)
{
sigset_t old_mask;
int old_hi;
sigprocmask(SIG_SETMASK, NULL, &old_mask);
split_sigset(old_mask, &old_hi, old_lo_p);
return old_hi;
}
/* Set/Get signal handlers
*******************************************************************************
*/
long int pending_signals = 0;
void scm_handle_sig(int sig) {pending_signals |= (1<<sig);}
s48_value set_int_handler(int sig, s48_value handler, int flags,
s48_value *ohandler, int *oflags)
{
struct sigaction new, old;
sigemptyset(&new.sa_mask); /* WTF */
new.sa_flags = flags;
if( handler == S48_FALSE ) new.sa_handler = SIG_IGN;
else if( handler == S48_TRUE ) new.sa_handler = SIG_DFL;
else {
new.sa_handler = scm_handle_sig;
/* Do other stuff. */
}
if( sigaction(sig, &new, &old) ) {
*ohandler = S48_FALSE;
return s48_enter_fixnum(errno);
}
*oflags = old.sa_flags;
/* if( old.sa_handler == SIG_IGN ) *ohandler = S48_FALSE;
else if( old.sa_handler == SIG_DFL ) *ohandler = S48_TRUE;
else if( old.sa_handler == scm_handle_sig ) {
*ohandler = s48_enter_fixnum(0); /* Fix later. */
}
else *ohandler = s48_enter_fixnum(-1); /* Unknown signal handler. */
return S48_FALSE;
}
s48_value get_int_handler(int signal, s48_value *handler, int *flags)
{
struct sigaction old;
if( sigaction(signal, NULL, &old) ) {
*handler = S48_FALSE;
return s48_enter_fixnum(errno);
}
*flags = old.sa_flags;
if( old.sa_handler == SIG_IGN ) *handler = S48_FALSE;
else if( old.sa_handler == SIG_DFL ) *handler = S48_TRUE;
else if( old.sa_handler == scm_handle_sig ) {
*handler = s48_enter_fixnum(0); /* Fix later. */
}
else *handler = s48_enter_fixnum(-1); /* Unknown signal handler. */
return S48_FALSE;
}

View File

@ -1,76 +0,0 @@
/* This is an Scheme48/C interface file,
** automatically generated by cig.
*/
#include <stdio.h>
#include <stdlib.h> /* For malloc. */
#include "libcig.h"
#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)
scheme_value df_set_procmask(long nargs, scheme_value *args)
{
extern int set_procmask(int , int , int *);
scheme_value ret1;
int r1;
int r2;
cig_check_nargs(3, nargs, "set_procmask");
r1 = set_procmask(EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), &r2);
ret1 = ENTER_FIXNUM(r1);
VECTOR_REF(*args,0) = ENTER_FIXNUM(r2);
return ret1;
}
scheme_value df_get_procmask(long nargs, scheme_value *args)
{
extern int get_procmask(int *);
scheme_value ret1;
int r1;
int r2;
cig_check_nargs(1, nargs, "get_procmask");
r1 = get_procmask(&r2);
ret1 = ENTER_FIXNUM(r1);
VECTOR_REF(*args,0) = ENTER_FIXNUM(r2);
return ret1;
}
scheme_value df_set_int_handler(long nargs, scheme_value *args)
{
extern scheme_value set_int_handler(int , scheme_value , int , scheme_value *, int *);
scheme_value ret1;
scheme_value r1;
scheme_value r2;
int r3;
cig_check_nargs(4, nargs, "set_int_handler");
r1 = set_int_handler(EXTRACT_FIXNUM(args[3]), args[2], EXTRACT_FIXNUM(args[1]), &r2, &r3);
ret1 = r1;
VECTOR_REF(*args,0) = r2;
VECTOR_REF(*args,1) = ENTER_FIXNUM(r3);
return ret1;
}
scheme_value df_get_int_handler(long nargs, scheme_value *args)
{
extern scheme_value get_int_handler(int , scheme_value *, int *);
scheme_value ret1;
scheme_value r1;
scheme_value r2;
int r3;
cig_check_nargs(2, nargs, "get_int_handler");
r1 = get_int_handler(EXTRACT_FIXNUM(args[1]), &r2, &r3);
ret1 = r1;
VECTOR_REF(*args,0) = r2;
VECTOR_REF(*args,1) = ENTER_FIXNUM(r3);
return ret1;
}

View File

@ -1,168 +0,0 @@
;;; 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))

View File

@ -1,10 +0,0 @@
/* Convert between a lo24/hi integer-pair bitset and a sigset_t value.
** These macros are OS-dependent, and must be defined per-OS.
*/
#define make_sigset(maskp, hi, lo) \
((maskp)->__val[0] = (unsigned long int) ((hi) << 24) | (lo))
#define split_sigset(mask, hip, lop)\
((*(hip) = ((mask).__val[0] >> 24) & 0xff),\
(*(lop) = ((mask).__val[0] & 0xffffff)))

View File

@ -29,37 +29,6 @@ int sig2interrupt(int signal)
} }
/* Hack the blocked-signal mask.
*******************************************************************************
*/
#include "machine/sigset.h"
int set_procmask(int hi, int lo, int *old_lo_p)
{
sigset_t mask, old_mask;
int old_hi;
make_sigset(&mask, hi, lo);
sigprocmask(SIG_SETMASK, &mask, &old_mask);
split_sigset(old_mask, &old_hi, old_lo_p);
return old_hi;
}
int get_procmask(int *old_lo_p)
{
sigset_t old_mask;
int old_hi;
sigprocmask(SIG_SETMASK, NULL, &old_mask);
split_sigset(old_mask, &old_hi, old_lo_p);
return old_hi;
}
/* Set/Get signal handlers /* Set/Get signal handlers
******************************************************************************* *******************************************************************************
*/ */

View File

@ -1,10 +0,0 @@
/* Convert between a lo24/hi integer-pair bitset and a sigset_t value.
** These macros are OS-dependent, and must be defined per-OS.
*/
#define make_sigset(maskp, hi, lo) ((maskp)->__sigbits[0]=((hi)<<24)|(lo))
/* Not a procedure: */
#define split_sigset(mask, hip, lop) \
((*(hip)=((mask).__sigbits[0]>>24)&0xff), \
(*(lop)=((mask).__sigbits[0]&0xffffff)))