scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

removed bogus files

This commit is contained in:
mainzelm 2000-12-21 12:11:23 +00:00
parent aa8647061d
commit 56234c5ae2
6 changed files with 0 additions and 2288 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

533
scsh/fdports1.old.c
View File

@ -1,533 +0,0 @@
/* This file contains the code for doing the scsh file ports stuff.
** Copyright (c) 1993, 1994 by Olin Shivers.
**
** Note that this code mutates Scheme records -- it has the layout
** of fdports and their data records wired in. This is somewhat fragile.
*/
/* A note on the clearerr() calls herein: SunOS stdio input routines,
** contrary to POSIX, will return EOF if the stream's EOF flag is set,
** without trying to read the stream. This is a lose for tty's, which
** can frequently still be read from after the first EOF (e.g., if you
** type a ^D to bag out of a breakpoint, you would like the terminal
** input port to not shut down forever.)
**
** To fix this lossage, we are careful to call clearerr() before every
** input stream op.
*/
/* We maintain the following invariant: every open port has a FILE*
** associated with it.
*/
#include "sysdep.h"
#include <stdio.h>
#include <fcntl.h>
#include <unistd.h>
#include <stdlib.h>
#include <errno.h>
#include "cstuff.h"
#define NUM_FDPORTS 256
#include "fdports.h"
#include "machine/stdio_dep.h"
/* Make sure our exports match up w/the implementation: */
#include "fdports1.h"
extern int errno;
/* Maps fd's to FILE*'s. */
static FILE *fstar_cache[NUM_FDPORTS] = {NULL};
/* Maps fd's to ports. */
static s48_value fdports[NUM_FDPORTS] = {SCHFALSE};
void init_fdports(void)
{
int i = NUM_FDPORTS;
#ifdef linux
/* Gross hack to cover for Linux lossage. -Olin */
extern void remove_bone_from_head_of_linux_libc (void);
remove_bone_from_head_of_linux_libc();
#endif
while( i-- ) fdports[i] = S48_FALSE;
/* Specially hack stdio. */
fstar_cache[fileno(stdin)] = stdin;
fstar_cache[fileno(stdout)] = stdout;
fstar_cache[fileno(stderr)] = stderr;
}
/* (maybe_fdes2port fd)
** Return: the port if there is one allocated; otherwise #f.
** If a port is returned, the revealed count is NOT incremented.
*/
s48_value maybe_fdes2port(int fd)
{
if( fd < 0 || fd >= NUM_FDPORTS )
return S48_FALSE;
return fdports[fd];
}
#if 0
/* Bogus old code. We now compute the mode string from the actual fd. */
static char const *mode2string(int mode)
{
if( mode == 0 ) return "r";
else if( mode == 1 ) return "w";
else if( mode == 2 ) return "r+";
else return "x"; /* What??? */
}
#endif
static char const *fdes_modestr(int fd)
{
int flags = fcntl(fd,F_GETFL);
if( flags == -1 ) return NULL;
flags &= O_ACCMODE;
if( flags == O_WRONLY ) return "w";
else if( flags == O_RDONLY ) return "r";
else if( flags == O_RDWR ) return "r+";
fputs("That's impossible.\n", stderr);
abort();
_exit(-1);
/*NOTREACHED*/
}
/* Returns a char, #f for EOF, or errno. */
s48_value fdport_getchar(s48_value data)
{
int fd = s48_extract_fixnum(*PortData_Fd(data));
FILE *f = fstar_cache[fd];
int c;
clearerr(f);
c = getc(f);
if( EOF == c )
return ferror(f) ? s48_enter_fixnum(errno) : S48_FALSE;
else
return s48_enter_char(c);
}
int fdport_putchar(s48_value data, char c)
{
int fd = s48_extract_fixnum(*PortData_Fd(data));
FILE *f = fstar_cache[fd];
int retval = putc(c,f);
return (retval == EOF) ? errno : 0;
}
/* Not POSIX, so we punt to an OS-specific routine. */
s48_value fdport_char_readyp(s48_value data)
{
extern s48_value stream_char_readyp(FILE *);
return stream_char_readyp(fstar_cache[s48_extract_fixnum(*PortData_Fd(data))]);
}
int flush_fdport(s48_value data)
{
FILE *f = fstar_cache[s48_extract_fixnum(*PortData_Fd(data))];
return fflush(f) ? errno : 0;
}
/* This is actually just fflush(NULL), but apparently the pinheads
** at Sun can't be bothered to implement ANSI C or POSIX, so this op
** cleverly dumps core. Hence we do this incomplete approximation.
*/
int flush_all_ports(void)
{
int i;
for(i=0; i<NUM_FDPORTS; i++)
if(fstar_cache[i]) fflush(fstar_cache[i]);
return 0;
/* return fflush(NULL) ? errno : 0; THE REAL SOLUTION.*/
}
int seek_fdport(s48_value data, off_t offset, int whence, int *newpos)
{
FILE *f = fstar_cache[s48_extract_fixnum(*PortData_Fd(data))];
*PortData_Peek(data) = S48_FALSE; /* Flush buffered data. */
if( fseek(f, offset, whence) ) /* seek */
{ *newpos = 0; return errno; }
*newpos = ftell(f); /* tell */
return (*newpos < 0) ? errno : 0;
}
int tell_fdport( s48_value data, int *newpos )
{
FILE *f = fstar_cache[s48_extract_fixnum(*PortData_Fd(data))];
*newpos = ftell(f);
return (*newpos < 0) ? errno : 0;
}
int set_fdbuf( s48_value data, int policy, int bufsize )
{
FILE *f = fstar_cache[s48_extract_fixnum(*PortData_Fd(data))];
int size = (bufsize < 0) ? BUFSIZ : bufsize;
return setvbuf(f, NULL, policy, size) ? errno : 0;
}
int close_fdport(s48_value port_data)
{
if( *PortData_Closed(port_data) == S48_FALSE ) {
int fd = s48_extract_fixnum(*PortData_Fd(port_data));
FILE *f = fstar_cache[fd];
if( fclose(f) ) return errno;
*PortData_Fd(port_data) = S48_FALSE;
fdports[fd] = S48_FALSE;
*PortData_Closed(port_data) = S48_TRUE;
*PortData_Peek(port_data) = S48_FALSE;
fstar_cache[fd] = NULL;
return 0;
}
else return EBADF; /* Already closed. */
}
static int cloexec_fdport(s48_value port_data)
{
int fd = s48_extract_fixnum(*PortData_Fd(port_data));
return fcntl(fd, F_SETFD, FD_CLOEXEC) ? errno : 0;
}
int install_port(int fd, s48_value port, int revealed)
{
FILE *stream;
const char *modestr;
if( fd < 0 || fd >= NUM_FDPORTS ) return -1;
if( fdports[fd] != S48_FALSE ) return -2;
if( !(modestr = fdes_modestr(fd)) )
return -3;
fdports[fd] = port;
if( !revealed )
if( set_cloexec(fd, 1) ) return errno;
if( fstar_cache[fd] ) return 0; /* A hack mainly for stdio. */
fstar_cache[fd] = stream = fdopen(fd, modestr);
return stream ? 0 : errno;
}
FILE *fdes2fstar(int fd)
{
if( fstar_cache[fd] ) return fstar_cache[fd];
else {
const char *modestr = fdes_modestr(fd);
return modestr ? fdopen(fd, modestr) : NULL;
}
}
/* fd_from's FILE* structure is changed to be fd_to's FILE* structure.
** So buffered data isn't lost. Return 0 on failure.
** Rather non-portable.
*/
static int move_fstar(int fd_from, int fd_to)
{
FILE *f1 = fdes2fstar(fd_from);
if( !f1 ) return 0;
setfileno(f1, fd_to);
fstar_cache[fd_from] = NULL;
fstar_cache[fd_to] = f1;
return 1;
}
/* Move port so that it's underlying file descriptor is fd.
** The port's underlying FILE* is also shifted over, so that
** buffered data isn't lost on a shift. Return 0 on success.
*/
int move_fdport(int fd, s48_value port, int new_revealed)
{
s48_value port_data = *Port_PortData(port);
int old_fd = s48_extract_fixnum(*PortData_Fd(port_data));
if( fd < 0 || fd >= NUM_FDPORTS ) return 1;
/* You are allowed to "move" a port to its current fd.
Otherwise, the fd must be unallocated. Kluge. */
if( fdports[fd] != port ) {
if( fdports[fd] != S48_FALSE ) return 1; /* Target already allocated. */
if( !move_fstar(old_fd, fd) ) return 1;
fdports[fd] = port;
fdports[old_fd] = S48_FALSE;
*PortData_Fd(port_data) = s48_enter_fixnum(fd);
}
/* Unreveal the port by shifting the revealed count
over to the old-revealed count. */
*PortData_OldRev(port_data) = s48_enter_fixnum(s48_extract_fixnum(*PortData_OldRev(port_data))+
s48_extract_fixnum(*PortData_Rev(port_data)));
*PortData_Rev(port_data) = s48_enter_fixnum(new_revealed);
if( !new_revealed ) return set_cloexec(fd, 1);
return 0;
}
/* Scan the fdports vector after a gc. Uncopied unrevealed ports
** have their fds closed. The fdports vec is updated with the copy.
*/
#ifdef TEST_GC
void post_gc_fdports(void) {}
#else
void post_gc_fdports(void)
{
int fd;
#ifdef NOISY_FDGC
fputs("{GC", stderr); fflush(stderr);
#endif
for(fd=0; fd<NUM_FDPORTS; fd++) {
s48_value port = fdports[fd];
if(STOBP(port)) {
long header = STOB_HEADER(port);
if(STOBP(header)) {
#ifdef NOISY_FDGC
fprintf(stderr, "Copying port[fd] %d[%d] header %d\n",
port, fd, header);
fflush(stderr);
#endif
/* Port was copied, so update fdports entry. */
fdports[fd] = header;
}
else {
/* Port wasn't copied -- is garbage.
If fd unrevealed, close it. */
int rev = s48_extract_fixnum(*PortRev(port));
#ifdef NOISY_FDGC
fprintf(stderr, "GC'ing %srevealed port[fd] %d[%d]\n",
rev == 0 ? "un" : "",
port, fd);
fflush(stderr);
#endif
if( rev == 0 )
/* Close, even if interrupted -- GC's must be atomic. */
while( EINTR == close_fdport(*Port_PortData(port)) );
fdports[fd] = S48_FALSE; /* Drop the port. */
}
}
}
#ifdef NOISY_FDGC
fputs("}", stderr); fflush(stderr);
#endif
}
#endif
#define Min(a,b) (((a) < (b)) ? (a) : (b)) /* Not a function. */
/* Note the clearerr() call. This is so a ^D on a tty input stream
** doesn't shut the stream down forever. SunOS doesn't handle this according
** to POSIX spec, so we have to explicitly hack this case.
*/
static int read_stream_substring(s48_value buf, int start, int end, FILE *f)
{
char *p = StrByte(buf,start);
int len = end-start;
clearerr(f);
/* If there's data in the buffer, use it. */
if (fbufcount(f) > 0)
return fread(p, 1, Min(len, fbufcount(f)), f);
/* Otherwise, do a read. */
return read(fileno(f), p, len);
}
#define MIN(a,b) (((a) < (b)) ? (a) : (b)) /* Not a function. */
int read_fdport_substring(s48_value buf, int start, int end, s48_value data)
{
s48_value peek = *PortData_Peek(data);
FILE *f = fstar_cache[s48_extract_fixnum(*PortData_Fd(data))];
clearerr(f); /* SunOS sux. */
/* If there's a peek char, then we'll use it and
whatever is buffered in the FILE*. */
if( IsChar(peek) ) {
int len = end-start;
if( len > 0 ) {
char *p = StrByte(buf,start);
*p++ = s48_extract_char(peek);
*PortData_Peek(data) = S48_FALSE;
return 1 + fread(p, 1, MIN(len-1, fbufcount(f)), f);
}
else return 0;
}
/* Otherwise, just do a read_stream_substring. */
return read_stream_substring(buf, start, end, f);
}
/* We assume either fileno(f) does blocking i/o or f is unbuffered. */
int write_fdport_substring(s48_value buf, int start, int end, s48_value data)
{
FILE *f = fstar_cache[s48_extract_fixnum(*PortData_Fd(data))];
int nbytes = end - start;
int retval = fwrite(StrByte(buf,start), 1, nbytes, f);
return (retval < nbytes) ? -1 : retval; /* -1: error, otw numwritten */
}
/* 1st return value says why we terminated the read:
** - integer errno if error.
** - char c if string terminated by char c (which is consumed).
** - eof object if string terminated by EOF
** - #f if buf overflow.
**
** 2nd return value is num chars read into BUF.
**
** GOBBLE boolean says whether or not to read a terminating delimiter char
** or just leave it in the input stream.
**
** N.B.:
** - This code is dependent on the representation of scsh's char-sets.
** We assume they are 256-elt strings. If this changes, we'd have to
** rewrite the code.
** - This procedure is made more complex by the fact that we may have to take
** the first char read from the *port's* peek-char slot.
** - buffer-full/terminated-char ties are broken in favor of successful
** termination.
*/
s48_value read_delim(const char *delims, char *buf, int gobble,
s48_value port, int start, int end,
int *nread)
{
s48_value data = *Port_PortData(port);
s48_value peekc = *PortData_Peek(data);
int fd = s48_extract_fixnum(*PortData_Fd(data));
FILE *f = fstar_cache[fd];
char *cptr = buf+start-1, /* Location of last char deposited. */
*bufend = buf+end-1; /* Last writeable position. */
/* This chunk of code is necessary because we have to check
** the port's one-char pushback slot before going to the port's
** stdio FILE*. Yech.
*/
if( IsChar(peekc) ) {
char c = s48_extract_char(peekc);
if( delims[c] ) { /* Is c in cset? */
if( gobble ) *PortData_Peek(data) = S48_FALSE;
*nread = 0;
return peekc;
}
else if( start >= end ) {
*nread = 0; /* Overflow. */
return S48_FALSE;
}
else {
*++cptr = c;
*PortData_Peek(data) = S48_FALSE;
}
}
clearerr(f);
while( 1 ) {
int c = getc(f);
if( EOF == c ) { /* Terminal case: EOF or error. */
*nread = 1 + cptr - buf - start;
return ferror(f) ? s48_enter_fixnum(errno) : S48_EOF;
}
else if( delims[c] ) { /* Terminal case: delimiter char. */
s48_value ch = s48_enter_char(c);
*nread = 1 + cptr - buf - start;
if( !gobble ) *PortData_Peek(data) = ch;
return ch;
}
else if( cptr >= bufend ) { /* Terminal case: buffer overflow. */
*PortData_Peek(data) = s48_enter_char(c); /* Put C back. */
*nread = end-start;
return S48_FALSE;
}
else *++cptr = c;
}
}
s48_value skip_chars(const char *skipchars, s48_value port, int *nread)
{
s48_value data = *Port_PortData(port);
s48_value peekc = *PortData_Peek(data);
int fd = s48_extract_fixnum(*PortData_Fd(data));
FILE *f = fstar_cache[fd];
int nr = 0; /* Number of skip chars read. */
/* This chunk of code is necessary because we have to check
** the port's one-char pushback slot before going to the port's
** stdio FILE*. Yech.
*/
if( IsChar(peekc) ) {
int c = s48_extract_char(peekc);
if( skipchars[c] ) { /* Is c in cset? */
*PortData_Peek(data) = S48_FALSE;
nr = 1;
}
else {
*nread = 0;
return S48_FALSE;
}
}
clearerr(f);
while( 1 ) {
int c = getc(f);
if( EOF == c ) { /* Terminal case: EOF or error. */
*nread = nr;
return ferror(f) ? s48_enter_fixnum(errno) : S48_FALSE;
}
else if( !skipchars[c] ) { /* Terminal case: non-skip char. */
*PortData_Peek(data) = s48_enter_char(c);
*nread = nr;
return S48_FALSE;
}
nr++;
}
}
/* Why, you might ask, do I push back the final char using the Scheme port
** instead of using ungetc()? Because ungetc() isn't guaranteed to work for
** unbuffered ports. This is regrettable, because it causes C stdio clients
** that are ignorant of the Scheme port machinery to miss this char. No
** real help for it.
*/

572
scsh/newports.old.2.scm
View File

@ -1,572 +0,0 @@
;;; A Unix file port system to completely replace S48 file ports.
;;; We use S48 extensible ports.
;;; Copyright (c) 1993 by Olin Shivers.
;(define-record fdport-data
; fd ; Unix file descriptor - integer.
; (closed? #f) ; Is port closed.
; (peek-char #f)
; revealed ; REVEALED & OLD-REVEALED are for keeping
; (old-revealed 0)) ; track of whether the FD value has escaped.
(define-record fdport-data
channel
revealed)
;;; We could flush the PEEK-CHAR field and use stdio ungetc(), but it
;;; is only guaranteed for buffered streams. Too bad...
;Arbitrary, for now.
(define buffer-size 255)
;(define (alloc-input-fdport fd revealed)
; (make-port input-fdport-handler open-input-port-status (make-lock) #f
; (make-fdport-data fd revealed)
; (make-code-vector buffer-size (char->ascii #\!)) 0
; 0 #f))
(define (alloc-input-fdport fd revealed)
(make-input-port input-fdport-handler
(make-fdport-data (make-input-fdchannel fd) revealed)
(make-code-vector buffer-size 0) 0 0))
;Have to use make-port, make-output-port wants to use code-vectors
;(define (alloc-output-fdport fd revealed)
; (make-port output-fdport-handler open-output-port-status (make-lock) #f
; (make-fdport-data fd revealed) (make-string buffer-size) 0
; buffer-size #f))
(define (alloc-output-fdport fd revealed)
(make-output-port output-fdport-handler
(make-fdport-data (make-output-fdchannel fd) revealed)
(make-code-vector buffer-size 0) 0 buffer-size))
;(define (make-input-fdport fd revealed)
; (let ((p (alloc-input-fdport fd revealed)))
; (%install-port fd p revealed)
; (add-finalizer! p (lambda (x) (close-fdport* (fdport-data x))))
; p))
(define make-input-fdport alloc-input-fdport)
;(define (make-output-fdport fd revealed)
; (let ((p (alloc-output-fdport fd revealed)))
; (%install-port fd p revealed)
; (periodically-force-output! p)
; (add-finalizer! p (lambda (x) (close-fdport* (fdport-data x))))
; p))
(define (make-output-fdport fd revealed)
(let ((p (alloc-output-fdport fd revealed)))
(periodically-force-output! p)
p))
;(define (fdport? x)
; (cond ((or (and (extensible-input-port? x)
; (extensible-input-port-local-data x))
; (and (extensible-output-port? x)
; (extensible-output-port-local-data x)))
; => (lambda (d) (fdport-data? d)))
; (else #f)))
(define (fdport? x)
(cond ((or (and (input-port? x) (port-data x))
(and (output-port? x) (port-data x)))
=> (lambda (d) (fdport-data? d)))
(else #f)))
;;; Basic methods
;;; -------------
(define fdport-null-method (lambda (x) x #f))
;;; CLOSE-FDPORT*, FLUSH-FDPORT* defined in syscalls.scm.
;;; (So you must load that file before loading this file.)
;(define (fdport*-read-char data)
; (check-arg open-fdport-data? data fdport*-read-char)
; (cond ((fdport-data:peek-char data) =>
; (lambda (char)
; (set-fdport-data:peek-char data #f)
; char))
; (else
; (or (%fdport*-read-char data) eof-object))))
(define (fdport*-read-char data)
(check-arg open-fdport-data? data fdport*-read-char)
(or (%fdport*-read-char data) (eof-object)))
;(define (fdport*-peek-char data)
; (check-arg open-fdport-data? data fdport*-peek-char)
; (or (fdport-data:peek-char data)
; (cond ((%fdport*-read-char data) =>
; (lambda (char)
; (set-fdport-data:peek-char data char)
; char))
; (else eof-object))))
;(define (fdport*-char-ready? data)
; (check-arg open-fdport-data? data fdport*-char-ready?)
; (or (fdport-data:peek-char data)
; (%fdport*-char-ready? data)))
(define (fdport*-char-ready? data)
(check-arg open-fdport-data? data fdport*-char-ready?)
(%fdport*-char-ready? data))
(define (fdport*-write-char data char)
(check-arg open-fdport-data? data fdport*-write-char)
(if (not (fdport-data:closed? data))
(%fdport*-write-char data char))
#f) ; Bogus fix -- otherwise %fdport*-...'s 0-value return blows up S48.
(define (fdport*-write-string data string)
(check-arg open-fdport-data? data fdport*-write-string)
(generic-write-string string 0 (string-length string) ; from rw.scm
write-fdport*-substring/errno data)
#f)
;(define input-fdport-methods
; (make-input-port-methods close-fdport*
; fdport*-read-char
; fdport*-peek-char
; fdport*-char-ready?
; fdport-null-method ; current-column
; fdport-null-method)) ; current-row
(define input-fdport-reader
(lambda (fdport buffer start-index needed-bytes)
(let* ((buffer-length (if (string? buffer) string-length
code-vector-length))
(buffer-set! (if (string? buffer) string-set! code-vector-set!))
(max-size (buffer-length buffer)))
(if (number? needed-bytes)
(let ((max-read (modulo (+ start-index needed-bytes) max-size)))
(let fill-buffer ((current-index start-index))
(if (eq? current-index max-read)
needed-bytes
(if (fdport*-char-ready? fdport)
(let ((found-char (fdport*-read-char fdport)))
(if (eof-object? found-char)
found-char
(begin
(buffer-set! buffer current-index
(char->ascii found-char))
(fill-buffer (modulo (+ current-index 1)
max-size)))))
(begin
(relinquish-timeslice)
(fill-buffer current-index))))))
(let ((immediate-get
(lambda ()
(let fill-buffer ((current-index start-index))
(if (and (< current-index max-size)
(fdport*-char-ready? fdport))
(begin
(let ((found-char (fdport*-read-char fdport)))
(if (not (eof-object? found-char))
(begin
(buffer-set! buffer current-index
(char->ascii found-char))
(fill-buffer (+ current-index 1)))
found-char)))
(- current-index start-index))))))
(cond
((eq? needed-bytes 'immediate) (immediate-get))
((eq? needed-bytes 'any)
(let fill-buffer ()
(if (fdport*-char-ready? fdport)
(immediate-get)
(begin
(relinquish-timeslice)
(fill-buffer)))))))))))
(define null-func (lambda args #t))
(define input-fdport-handler
(make-port-handler
(lambda (fdport)
(list 'fdport (fdport-data:fd fdport)))
close-fdport*
input-fdport-reader))
;(define output-fdport-methods
; (make-output-port-methods close-fdport*
; fdport*-write-char
; fdport*-write-string
; (lambda (d) ; force output
; (flush-fdport* d)
; #f) ; bogus workaround.
; fdport-null-method ; fresh-line
; fdport-null-method ; current-column
; fdport-null-method)) ; current-row
(define output-fdport-writer
(lambda (fdport buffer start-index needed-bytes)
(let* ((buffer-length (string-length buffer))
(to-print
(if (> (+ start-index needed-bytes) buffer-length)
(string-append (substring buffer start-index buffer-length)
(substring buffer 0
(- (+ start-index needed-bytes)
buffer-length)))
(substring buffer start-index (+ start-index needed-bytes)))))
(fdport*-write-string fdport to-print))))
(define output-fdport-handler
(make-port-handler
(lambda (fdport)
(list 'fdport (fdport-data:fd fdport)))
close-fdport*
output-fdport-writer))
(define unbuffered-output-fdport-handler
(make-port-handler
(lambda (fdport)
(list 'fdport (fdport-data:fd fdport)))
close-fdport*
fdport*-write-char))
;(define (fdport-data port)
; (let ((d ((cond ((extensible-input-port? port)
; extensible-input-port-local-data)
; ((extensible-output-port? port)
; extensible-output-port-local-data)
; (else (error "Illegal value" port)))
; port)))
; (if (and d (fdport-data? d)) d
; (error "fport closed" port))))
(define fdport-data port-data)
; That was easy.
(define (%fdport-seek/errno port offset whence)
(%fdport*-seek/errno (fdport-data port) offset whence))
(define (%fdport-tell/errno port)
(%fdport*-tell/errno (fdport-data port)))
(define (%fdport-set-buffering/errno port policy size)
(%fdport*-set-buffering/errno (fdport-data port) policy size))
(define (set-port-buffering port policy . maybe-size)
(let* ((size (if (pair? maybe-size)
(if (pair? (cdr maybe-size))
(error "Too many arguments." set-port-buffering)
(check-arg (lambda (s) (and (integer? s)
(<= 0 s)))
(car maybe-size)
set-port-buffering))
-1))
(policy (if (zero? size) bufpol/none policy))
(err (%fdport-set-buffering/errno port policy size)))
(if err (errno-error err set-port-buffering port policy size))))
;;; Open & Close
;;; ------------
(define (open-file fname flags . maybe-mode)
(let ((fd (apply open-fdes fname flags maybe-mode))
(access (bitwise-and flags open/access-mask)))
((if (or (= access open/read) (= access open/read+write))
make-input-fdport
make-output-fdport)
fd 0)))
(define (open-input-file fname . maybe-flags)
(let ((flags (:optional maybe-flags 0)))
(open-file fname (deposit-bit-field flags open/access-mask open/read))))
(define (open-output-file fname . rest)
(let* ((flags (if (pair? rest) (car rest)
(bitwise-ior open/create open/truncate))) ; default
(maybe-mode (if (null? rest) '() (cdr rest)))
(flags (deposit-bit-field flags open/access-mask open/write)))
(apply open-file fname flags maybe-mode)))
;;; All these revealed-count-hacking procs have atomicity problems.
;;; They need to run uninterrupted.
(define (increment-revealed-count port delta)
(let* ((data (fdport-data port))
(count (fdport-data:revealed data))
(newcount (+ count delta)))
(set-fdport-data:revealed data newcount)
(if (and (zero? count) (> newcount 0)) ; We just became revealed,
(%set-cloexec (fdport-data:fd data) #f)))) ; so don't close on exec().
(define (release-port-handle port)
(check-arg fdport? port port->fdes)
(let* ((data (fdport-data port))
(rev (fdport-data:revealed data)))
(if (zero? rev)
(set-fdport-data:old-revealed data
(- (fdport-data:old-revealed data) 1))
(let ((new-rev (- rev 1)))
(set-fdport-data:revealed data new-rev)
(if (zero? new-rev) ; We just became unrevealed, so
(%set-cloexec (fdport-data:fd data) #t)))))); the fd can be closed on exec.
(define (port-revealed port)
(let ((count (fdport-data:revealed
(fdport-data
(check-arg fdport? port port-revealed)))))
(and (not (zero? count)) count)))
(define (fdes->port fd port-maker) ; local proc.
(cond ((%maybe-fdes->port fd) =>
(lambda (p)
(increment-revealed-count p 1)
p))
(else (port-maker fd 1))))
(define (fdes->inport fd) (fdes->port fd make-input-fdport))
(define (fdes->outport fd) (fdes->port fd make-output-fdport))
(define (port->fdes port)
(check-arg open-fdport? port port->fdes)
(let ((data (fdport-data port)))
(increment-revealed-count port 1)
(fdport-data:fd data)))
(define (call/fdes fd/port proc)
(cond ((integer? fd/port)
(proc fd/port))
((fdport? fd/port)
(let ((port fd/port))
(dynamic-wind
(lambda ()
(if (not port) (error "Can't throw back into call/fdes.")))
(lambda () (proc (port->fdes port)))
(lambda ()
(release-port-handle port)
(set! port #f)))))
(else (error "Not a file descriptor or fdport." fd/port))))
;;; Don't mess with the revealed count in the port case
;;; -- just sneakily grab the fdes and run.
(define (sleazy-call/fdes fd/port proc)
(proc (cond ((integer? fd/port) fd/port)
((fdport? fd/port) (fdport-data:fd (fdport-data fd/port)))
(else (error "Not a file descriptor or fdport." fd/port)))))
;;; Random predicates and arg checkers
;;; ----------------------------------
(define (open-fdport-data? x)
(and (fdport-data? x)
(not (fdport-data:closed? x))))
;(define (open-fdport? x)
; (cond ((or (and (extensible-input-port? x)
; (extensible-input-port-local-data x))
; (and (extensible-output-port? x)
; (extensible-output-port-local-data x)))
; => (lambda (d) (and (fdport-data? d) (not (fdport-data:closed? d)))))
; (else #f)))
(define (open-fdport? x)
(and (fdport? x) (or (open-output-port? x) (open-input-port? x))))
;(define (extensible-port-local-data xport)
; ((if (extensible-input-port? xport)
; extensible-input-port-local-data
; extensible-output-port-local-data)
; xport))
(define (fdport-open? port)
(check-arg fdport? port fdport-open?)
(not (fdport-data:closed? (port-data port))))
;;; Initialise the system
;;; ---------------------
(define old-inport #f) ; Just because.
(define old-outport #f)
(define old-errport #f)
(define (init-fdports!)
(%init-fdports!)
(if (not (fdport? (current-input-port)))
(set! old-inport (current-input-port)))
(if (not (fdport? (current-output-port)))
(set! old-outport (current-output-port)))
(if (not (fdport? (current-error-port)))
(set! old-errport (current-error-port)))
(let ((iport (fdes->inport 0))
(oport (fdes->outport 1)))
(set-port-buffering iport bufpol/none) ; Stdin is unbuffered.
(set-port-buffering oport bufpol/none)
(set-fluid! $current-input-port iport)
(set-fluid! $current-output-port oport)
(set-fluid! $current-error-port (fdes->outport 2))))
;;; Generic port operations
;;; -----------------------
;;; (close-after port f)
;;; Apply F to PORT. When F returns, close PORT, then return F's result.
;;; Does nothing special if you throw out or throw in.
(define (close-after port f)
(receive vals (f port)
(close port)
(apply values vals)))
(define (close port/fd)
((cond ((integer? port/fd) close-fdes)
((output-port? port/fd) close-output-port)
((input-port? port/fd) close-input-port)
(else (error "Not file-descriptor or port" port/fd))) port/fd))
;;; If this fd has an associated input or output port,
;;; move it to a new fd, freeing this one up.
(define (evict-ports fd)
(cond ((%maybe-fdes->port fd) => ; Shouldn't bump the revealed count.
(lambda (port)
(%move-fdport (%dup fd) port 0)))))
(define (close-fdes fd)
(evict-ports fd)
(%close-fdes fd))
;;; Extend R4RS i/o ops to handle file descriptors.
;;; -----------------------------------------------
(define s48-char-ready? (structure-ref scheme char-ready?))
(define s48-read-char (structure-ref scheme read-char))
(define-simple-syntax
(define-r4rs-input (name arg ...) stream s48name body ...)
(define (name arg ... . maybe-i/o)
(let ((stream (:optional maybe-i/o (current-input-port))))
(cond ((input-port? stream) (s48name arg ... stream))
((integer? stream) body ...)
(else (error "Not a port or file descriptor" stream))))))
(define-r4rs-input (char-ready?) input s48-char-ready?
(%char-ready-fdes? input))
(define-r4rs-input (read-char) input s48-read-char
(read-fdes-char input))
;structure refs changed to get reference from scheme -dalbertz
(define s48-display (structure-ref scheme display))
(define s48-newline (structure-ref scheme newline))
(define s48-write (structure-ref scheme write))
(define s48-write-char (structure-ref scheme write-char))
(define s48-format (structure-ref formats format))
(define s48-force-output (structure-ref i/o force-output))
(define-simple-syntax
(define-r4rs-output (name arg ...) stream s48name body ...)
(define (name arg ... . maybe-i/o)
(let ((stream (:optional maybe-i/o (current-output-port))))
(cond ((output-port? stream) (s48name arg ... stream))
((integer? stream) body ...)
(else (error "Not a port or file descriptor" stream))))))
;;; This one depends upon S48's string ports.
(define-r4rs-output (display object) output s48-display
(let ((sp (make-string-output-port)))
(display object sp)
(write-string (string-output-port-output sp) output)))
(define-r4rs-output (newline) output s48-newline
(write-fdes-char #\newline output))
(define-r4rs-output (write object) output s48-write
(let ((sp (make-string-output-port)))
(write object sp)
(write-string (string-output-port-output sp) output)))
(define-r4rs-output (write-char char) output s48-write-char
(write-fdes-char char output))
;;; S48's force-output doesn't default to forcing (current-output-port).
(define-r4rs-output (force-output) output s48-force-output
(values)) ; Do nothing if applied to a file descriptor.
(define (format dest cstring . args)
(if (integer? dest)
(write-string (apply s48-format #f cstring args) dest)
(apply s48-format dest cstring args)))
;;; with-current-foo-port procs
;;; ---------------------------
(define (with-current-input-port* port thunk)
(let-fluid $current-input-port port thunk))
(define (with-current-output-port* port thunk)
(let-fluid $current-output-port port thunk))
(define (with-current-error-port* port thunk)
(let-fluid $current-error-port port thunk))
(define-simple-syntax (with-current-input-port port body ...)
(with-current-input-port* port (lambda () body ...)))
(define-simple-syntax (with-current-output-port port body ...)
(with-current-output-port* port (lambda () body ...)))
(define-simple-syntax (with-current-error-port port body ...)
(with-current-error-port* port (lambda () body ...)))
;;; set-foo-port! procs
;;; -------------------
;;; Side-effecting variants of with-current-input-port* and friends.
(define (set-current-input-port! port) (set-fluid! $current-input-port port))
(define (set-current-output-port! port) (set-fluid! $current-output-port port))
(define (set-current-error-port! port) (set-fluid! $current-error-port port))
;;; call-with-foo-file with-foo-to-file
;;; -----------------------------------
;;; Copied straight from rts/port.scm, but re-defined in this module,
;;; closed over my versions of open-input-file and open-output-file.
(define (call-with-mumble-file open close)
(lambda (string proc)
(let ((port #f))
(dynamic-wind (lambda ()
(if port
(warn "throwing back into a call-with-...put-file"
string)
(set! port (open string))))
(lambda () (proc port))
(lambda ()
(if port
(close port)))))))
(define call-with-input-file
(call-with-mumble-file open-input-file close-input-port))
(define call-with-output-file
(call-with-mumble-file open-output-file close-output-port))
(define (with-input-from-file string thunk)
(call-with-input-file string
(lambda (port)
(let-fluid $current-input-port port thunk))))
(define (with-output-to-file string thunk)
(call-with-output-file string
(lambda (port)
(let-fluid $current-output-port port thunk))))

437
scsh/newports.old.scm
View File

@ -1,437 +0,0 @@
;;; A Unix file port system to completely replace S48 file ports.
;;; We use S48 extensible ports.
;;; Copyright (c) 1993 by Olin Shivers.
(define-record fdport-data
fd ; Unix file descriptor - integer.
(closed? #f) ; Is port closed.
(peek-char #f)
revealed ; REVEALED & OLD-REVEALED are for keeping
(old-revealed 0)) ; track of whether the FD value has escaped.
;;; We could flush the PEEK-CHAR field and use stdio ungetc(), but it
;;; is only guaranteed for buffered streams. Too bad...
(define (alloc-input-fdport fd revealed)
(make-extensible-input-port (make-fdport-data fd revealed)
input-fdport-methods))
(define (alloc-output-fdport fd revealed)
(make-extensible-output-port (make-fdport-data fd revealed)
output-fdport-methods))
(define (make-input-fdport fd revealed)
(let ((p (alloc-input-fdport fd revealed)))
(%install-port fd p revealed)
p))
(define (make-output-fdport fd revealed)
(let ((p (alloc-output-fdport fd revealed)))
(%install-port fd p revealed)
p))
(define (fdport? x)
(cond ((or (and (extensible-input-port? x)
(extensible-input-port-local-data x))
(and (extensible-output-port? x)
(extensible-output-port-local-data x)))
=> (lambda (d) (fdport-data? d)))
(else #f)))
;;; Basic methods
;;; -------------
(define fdport-null-method (lambda (x) x #f))
;;; CLOSE-FDPORT*, FLUSH-FDPORT* defined in syscalls.scm.
;;; (So you must load that file before loading this file.)
(define (fdport*-read-char data)
(check-arg open-fdport-data? data fdport*-read-char)
(cond ((fdport-data:peek-char data) =>
(lambda (char)
(set-fdport-data:peek-char data #f)
char))
(else
(or (%fdport*-read-char data) eof-object))))
(define (fdport*-peek-char data)
(check-arg open-fdport-data? data fdport*-peek-char)
(or (fdport-data:peek-char data)
(cond ((%fdport*-read-char data) =>
(lambda (char)
(set-fdport-data:peek-char data char)
char))
(else eof-object))))
(define (fdport*-char-ready? data)
(check-arg open-fdport-data? data fdport*-char-ready?)
(or (fdport-data:peek-char data)
(%fdport*-char-ready? data)))
(define (fdport*-write-char data char)
(check-arg open-fdport-data? data fdport*-write-char)
(if (not (fdport-data:closed? data))
(%fdport*-write-char data char))
#f) ; Bogus fix -- otherwise %fdport*-...'s 0-value return blows up S48.
(define (fdport*-write-string data string)
(check-arg open-fdport-data? data fdport*-write-string)
(generic-write-string string 0 (string-length string) ; from rw.scm
write-fdport*-substring/errno data)
#f)
(define input-fdport-methods
(make-input-port-methods close-fdport*
fdport*-read-char
fdport*-peek-char
fdport*-char-ready?
fdport-null-method ; current-column
fdport-null-method)) ; current-row
(define output-fdport-methods
(make-output-port-methods close-fdport*
fdport*-write-char
fdport*-write-string
(lambda (d) ; force output
(flush-fdport* d)
#f) ; bogus workaround.
fdport-null-method ; fresh-line
fdport-null-method ; current-column
fdport-null-method)) ; current-row
(define (fdport-data port)
(let ((d ((cond ((extensible-input-port? port)
extensible-input-port-local-data)
((extensible-output-port? port)
extensible-output-port-local-data)
(else (error "Illegal value" port)))
port)))
(if (and d (fdport-data? d)) d
(error "fport closed" port))))
(define (%fdport-seek/errno port offset whence)
(%fdport*-seek/errno (fdport-data port) offset whence))
(define (%fdport-tell/errno port)
(%fdport*-tell/errno (fdport-data port)))
(define (%fdport-set-buffering/errno port policy size)
(%fdport*-set-buffering/errno (fdport-data port) policy size))
(define (set-port-buffering port policy . maybe-size)
(let* ((size (if (pair? maybe-size)
(if (pair? (cdr maybe-size))
(error "Too many arguments." set-port-buffering)
(check-arg (lambda (s) (and (integer? s)
(<= 0 s)))
(car maybe-size)
set-port-buffering))
-1))
(policy (if (zero? size) bufpol/none policy))
(err (%fdport-set-buffering/errno port policy size)))
(if err (errno-error err set-port-buffering port policy size))))
;;; Open & Close
;;; ------------
(define (open-file fname flags . maybe-mode)
(let ((fd (apply open-fdes fname flags maybe-mode))
(access (bitwise-and flags open/access-mask)))
((if (or (= access open/read) (= access open/read+write))
make-input-fdport
make-output-fdport)
fd 0)))
(define (open-input-file fname . maybe-flags)
(let ((flags (:optional maybe-flags 0)))
(open-file fname (deposit-bit-field flags open/access-mask open/read))))
(define (open-output-file fname . rest)
(let* ((flags (if (pair? rest) (car rest)
(bitwise-ior open/create open/truncate))) ; default
(maybe-mode (if (null? rest) '() (cdr rest)))
(flags (deposit-bit-field flags open/access-mask open/write)))
(apply open-file fname flags maybe-mode)))
;;; All these revealed-count-hacking procs have atomicity problems.
;;; They need to run uninterrupted.
(define (increment-revealed-count port delta)
(let* ((data (extensible-port-local-data port))
(count (fdport-data:revealed data))
(newcount (+ count delta)))
(set-fdport-data:revealed data newcount)
(if (and (zero? count) (> newcount 0)) ; We just became revealed,
(%set-cloexec (fdport-data:fd data) #f)))) ; so don't close on exec().
(define (release-port-handle port)
(check-arg fdport? port port->fdes)
(let* ((data (extensible-port-local-data port))
(rev (fdport-data:revealed data)))
(if (zero? rev)
(set-fdport-data:old-revealed data
(- (fdport-data:old-revealed data) 1))
(let ((new-rev (- rev 1)))
(set-fdport-data:revealed data new-rev)
(if (zero? new-rev) ; We just became unrevealed, so
(%set-cloexec (fdport-data:fd data) #t)))))); the fd can be closed on exec.
(define (port-revealed port)
(let ((count (fdport-data:revealed
(extensible-port-local-data
(check-arg fdport? port port-revealed)))))
(and (not (zero? count)) count)))
(define (fdes->port fd port-maker) ; local proc.
(cond ((%maybe-fdes->port fd) =>
(lambda (p)
(increment-revealed-count p 1)
p))
(else (port-maker fd 1))))
(define (fdes->inport fd) (fdes->port fd make-input-fdport))
(define (fdes->outport fd) (fdes->port fd make-output-fdport))
(define (port->fdes port)
(check-arg open-fdport? port port->fdes)
(let ((data (extensible-port-local-data port)))
(increment-revealed-count port 1)
(fdport-data:fd data)))
(define (call/fdes fd/port proc)
(cond ((integer? fd/port)
(proc fd/port))
((fdport? fd/port)
(let ((port fd/port))
(dynamic-wind
(lambda ()
(if (not port) (error "Can't throw back into call/fdes.")))
(lambda () (proc (port->fdes port)))
(lambda ()
(release-port-handle port)
(set! port #f)))))
(else (error "Not a file descriptor or fdport." fd/port))))
;;; Don't mess with the revealed count in the port case
;;; -- just sneakily grab the fdes and run.
(define (sleazy-call/fdes fd/port proc)
(proc (cond ((integer? fd/port) fd/port)
((fdport? fd/port) (fdport-data:fd (fdport-data fd/port)))
(else (error "Not a file descriptor or fdport." fd/port)))))
;;; Random predicates and arg checkers
;;; ----------------------------------
(define (open-fdport-data? x)
(and (fdport-data? x)
(not (fdport-data:closed? x))))
(define (open-fdport? x)
(cond ((or (and (extensible-input-port? x)
(extensible-input-port-local-data x))
(and (extensible-output-port? x)
(extensible-output-port-local-data x)))
=> (lambda (d) (and (fdport-data? d) (not (fdport-data:closed? d)))))
(else #f)))
(define (extensible-port-local-data xport)
((if (extensible-input-port? xport)
extensible-input-port-local-data
extensible-output-port-local-data)
xport))
(define (fdport-open? port)
(check-arg fdport? port fdport-open?)
(not (fdport-data:closed? (extensible-port-local-data port))))
;;; Initialise the system
;;; ---------------------
(define old-inport #f) ; Just because.
(define old-outport #f)
(define old-errport #f)
(define (init-fdports!)
(%init-fdports!)
(if (not (fdport? (current-input-port)))
(set! old-inport (current-input-port)))
(if (not (fdport? (current-output-port)))
(set! old-outport (current-output-port)))
(if (not (fdport? (error-output-port)))
(set! old-errport (error-output-port)))
(let ((iport (fdes->inport 0)))
(set-port-buffering iport bufpol/none) ; Stdin is unbuffered.
(set-fluid! $current-input-port iport)
(set-fluid! $current-output-port (fdes->outport 1))
(set-fluid! $error-output-port (fdes->outport 2))))
;;; Generic port operations
;;; -----------------------
;;; (close-after port f)
;;; Apply F to PORT. When F returns, close PORT, then return F's result.
;;; Does nothing special if you throw out or throw in.
(define (close-after port f)
(receive vals (f port)
(close port)
(apply values vals)))
(define (close port/fd)
((cond ((integer? port/fd) close-fdes)
((output-port? port/fd) close-output-port)
((input-port? port/fd) close-input-port)
(else (error "Not file-descriptor or port" port/fd))) port/fd))
;;; If this fd has an associated input or output port,
;;; move it to a new fd, freeing this one up.
(define (evict-ports fd)
(cond ((%maybe-fdes->port fd) => ; Shouldn't bump the revealed count.
(lambda (port)
(%move-fdport (%dup fd) port 0)))))
(define (close-fdes fd)
(evict-ports fd)
(%close-fdes fd))
;;; Extend R4RS i/o ops to handle file descriptors.
;;; -----------------------------------------------
(define s48-char-ready? (structure-ref scheme char-ready?))
(define s48-read-char (structure-ref scheme read-char))
(define-simple-syntax
(define-r4rs-input (name arg ...) stream s48name body ...)
(define (name arg ... . maybe-i/o)
(let ((stream (:optional maybe-i/o (current-input-port))))
(cond ((input-port? stream) (s48name arg ... stream))
((integer? stream) body ...)
(else (error "Not a port or file descriptor" stream))))))
(define-r4rs-input (char-ready?) input s48-char-ready?
(%char-ready-fdes? input))
(define-r4rs-input (read-char) input s48-read-char
(read-fdes-char input))
;structure refs changed to get reference from scheme -dalbertz
(define s48-display (structure-ref scheme display))
(define s48-newline (structure-ref scheme newline))
(define s48-write (structure-ref scheme write))
(define s48-write-char (structure-ref scheme write-char))
(define s48-format (structure-ref formats format))
(define s48-force-output (structure-ref ports force-output))
(define-simple-syntax
(define-r4rs-output (name arg ...) stream s48name body ...)
(define (name arg ... . maybe-i/o)
(let ((stream (:optional maybe-i/o (current-output-port))))
(cond ((output-port? stream) (s48name arg ... stream))
((integer? stream) body ...)
(else (error "Not a port or file descriptor" stream))))))
;;; This one depends upon S48's string ports.
(define-r4rs-output (display object) output s48-display
(let ((sp (make-string-output-port)))
(display object sp)
(write-string (string-output-port-output sp) output)))
(define-r4rs-output (newline) output s48-newline
(write-fdes-char #\newline output))
(define-r4rs-output (write object) output s48-write
(let ((sp (make-string-output-port)))
(write object sp)
(write-string (string-output-port-output sp) output)))
(define-r4rs-output (write-char char) output s48-write-char
(write-fdes-char char output))
;;; S48's force-output doesn't default to forcing (current-output-port).
(define-r4rs-output (force-output) output s48-force-output
(values)) ; Do nothing if applied to a file descriptor.
(define (format dest cstring . args)
(if (integer? dest)
(write-string (apply s48-format #f cstring args) dest)
(apply s48-format dest cstring args)))
;;; with-current-foo-port procs
;;; ---------------------------
(define (with-current-input-port* port thunk)
(let-fluid $current-input-port port thunk))
(define (with-current-output-port* port thunk)
(let-fluid $current-output-port port thunk))
(define (with-error-output-port* port thunk)
(let-fluid $error-output-port port thunk))
(define-simple-syntax (with-current-input-port port body ...)
(with-current-input-port* port (lambda () body ...)))
(define-simple-syntax (with-current-output-port port body ...)
(with-current-output-port* port (lambda () body ...)))
(define-simple-syntax (with-error-output-port port body ...)
(with-error-output-port* port (lambda () body ...)))
;;; set-foo-port! procs
;;; -------------------
;;; Side-effecting variants of with-current-input-port* and friends.
(define (set-current-input-port! port) (set-fluid! $current-input-port port))
(define (set-current-output-port! port) (set-fluid! $current-output-port port))
(define (set-error-output-port! port) (set-fluid! $error-output-port port))
;;; call-with-foo-file with-foo-to-file
;;; -----------------------------------
;;; Copied straight from rts/port.scm, but re-defined in this module,
;;; closed over my versions of open-input-file and open-output-file.
(define (call-with-mumble-file open close)
(lambda (string proc)
(let ((port #f))
(dynamic-wind (lambda ()
(if port
(warn "throwing back into a call-with-...put-file"
string)
(set! port (open string))))
(lambda () (proc port))
(lambda ()
(if port
(close port)))))))
(define call-with-input-file
(call-with-mumble-file open-input-file close-input-port))
(define call-with-output-file
(call-with-mumble-file open-output-file close-output-port))
(define (with-input-from-file string thunk)
(call-with-input-file string
(lambda (port)
(let-fluid $current-input-port port thunk))))
(define (with-output-to-file string thunk)
(call-with-output-file string
(lambda (port)
(let-fluid $current-output-port port thunk))))

340
scsh/procobj.old.scm
View File

@ -1,340 +0,0 @@
;;; Unix wait & process objects for scsh
;;; Copyright (c) 1993, 1994, 1995 by Olin Shivers.
;;; This is a GC'd abstraction for Unix process id's.
;;; The problem with Unix pids is (a) they clutter up the kernel
;;; process table until you wait(2) them, and (b) you can only
;;; wait(2) them once. Scsh's process objects are similar, but
;;; allow the storage to be allocated in the scsh address space,
;;; and out of the kernel process table, and they can be waited on
;;; multiple times.
;;; Process objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record proc ; A process object
pid ; Proc's pid.
(%status #f) ; The cached exit status of the process;
; #f if we haven't wait(2)'d the process yet.
;; Make proc objects print like #{proc 2318}.
((disclose p) (list "proc" (proc:pid p))))
;;; Indexing this table by pid requires a linear scan.
;;; Probably not an important op, tho.
(define process-table (make-population))
(define (maybe-pid->proc pid)
(call/cc (lambda (quit)
;; Search the table.
(walk-population (lambda (p)
(if (= (proc:pid p) pid) (quit p)))
process-table)
#f)))
(define (pid->proc pid . maybe-probe?)
(let ((probe? (:optional maybe-probe? #f)))
(or (maybe-pid->proc pid)
(case probe?
((#f) (error "Pid has no corresponding process object" pid))
((create) (let ((p (make-proc pid))) ; Install a new one.
(add-to-population! p process-table)
p))
(else #f)))))
;;; Coerce pids and procs to procs.
(define (->proc proc/pid)
(cond ((proc? proc/pid) proc/pid)
((and (integer? proc/pid) (>= proc/pid 0))
(pid->proc proc/pid))
(else (error "Illegal parameter" ->proc proc/pid))))
;;; Is X a pid or a proc?
(define (pid/proc? x) (or (proc? x) (and (integer? x) (>= pid 0))))
;;; Process reaping
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; "Reaping" a process means using wait(2) to move its exit status from the
;;; kernel's process table into scsh, thus cleaning up the kernel's process
;;; table and saving the value in a gc'd data structure, where it can be
;;; referenced multiple times.
;;;
;;; - Stopped processes are never reaped, only dead ones.
;;;
;;; - Stopped process status codes are never cached in proc objects,
;;; only status codes for dead processes. So you can wait for a
;;; dead process multiple times, but only once per process-stop.
;;;
;;; - Unfortunately, reaping a process loses the information specifying its
;;; process group, so if a process is reaped into scsh, it cannot be
;;; waited for by WAIT-PROCESS-GROUP. Notice that only dead processes are
;;; reaped, not suspended ones. Programs almost never use WAIT-PROCESS-GROUP
;;; to wait for dead processes, so this is not likely to be a problem. If
;;; it is, turn autoreaping off with (autoreap-policy #f).
;;;
;;; - Reaping can be encouraged by calling (REAP-ZOMBIES).
;;; (autoreap-policy [new-policy])
(define *autoreap-policy* #f) ; Not exported from this module.
(define (autoreap-policy . maybe-policy)
(let ((old-policy *autoreap-policy*))
(if (pair? maybe-policy)
(let ((new-policy (car maybe-policy)))
(cond ((pair? (cdr maybe-policy))
(error "Too many args to autoreap-policy" maybe-policy))
((not (memq new-policy '(early #f)))
(error "Illegal autoreap policy." new-policy))
(else (set! *autoreap-policy* new-policy)
(if (eq? new-policy 'early)
(set-interrupt-handler interrupt/chld
(lambda (enabled-ints) (reap-zombies))))))))
old-policy))
;;; (reap-zombies) => bool
;;; Move any zombies from the kernel process table into scsh.
;;; Return true if no more outstanding children; #f if some still live.
(define (reap-zombies)
(let lp ()
(receive (pid status) (%wait-any wait/poll)
(if pid
(begin (add-reaped-proc! pid status)
; (format (current-error-port)
; "Reaping ~d[~d]~%" pid status)
(lp))
status))))
;;; This list contains procs that haven't exited yet. FORK adds new
;;; procs to the list. When a proc exits, it is removed from the list.
;;; Being on this list keeps live children's proc objects from being gc'd.
(define unexited-procs '())
(define (new-child-proc pid)
(let ((proc (make-proc pid)))
(add-to-population! proc process-table)
(set! unexited-procs (cons proc unexited-procs))
proc))
(define (mark-proc-exited proc)
(set! unexited-procs (del proc unexited-procs)))
;;; (WAIT proc/pid [flags])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (wait proc/pid [flags]) => status or #f
;;;
;;; FLAGS (default 0) is the exclusive or of the following:
;;; wait/poll
;;; Return #f immediately if there are no
;;; unwaited children available.
;;; wait/stopped-children
;;; Report on suspended children as well.
;;;
;;; If the process hasn't terminated (or suspended, if wait/stopped
;;; is set) and wait/poll is set, return #f.
;;; WAIT waits for a specific process. Before performing a waitpid(2)
;;; systcall, wait first consults the proc object to see if the process has
;;; been reaped already. If so, its saved status is returned immediately.
;;;
(define (wait pid/proc . maybe-flags)
(let* ((flags (:optional maybe-flags 0))
(proc (->proc pid/proc))
(win (lambda (status)
(mark-proc-waited! proc) ; Not eligible for a WAIT-ANY
status)))
(let lp ()
;; First, see if we've already waited or reaped the process.
(cond ((proc:%status proc) => win)
(else ; Really wait.
(receive (err pid status) (%wait-pid/errno (proc:pid proc) flags)
(cond ((not err)
(and (not (zero? pid)) ; pid=0 => none ready.
(win (cache-wait-status proc status))))
((= err errno/intr) (lp))
;; We got an error -- before reporting it, check
;; the proc record one last time.
((proc:%status proc) => win)
(else (errno-error err %wait-pid pid flags)))))))))
;;; Another way to do it:
;;; Every time we reap a process, we pop out of our SIGCHLD
;;; block so that we can service an interrupt if the system
;;; so wishes.
;(define (wait/pid pid)
; ((let lp ()
; (blocking signal/chld
; (or (waited pid) ; Previously waited or reaped
; (receive (next-dead status) (reap-a-pid)
; (if (= pid next-dead) (lambda () status)
; lp)))))))
(define (cache-wait-status proc status)
(cond ((and (integer? status)
(not (status:stop-sig status))) ; He's dead, Jim.
(set-proc:%status proc status) ; Cache exit status.
(mark-proc-exited proc))) ; We're now gc'able.
status)
;;; (wait-any [flags]) => [proc status]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; [#f #f] => non-blocking, none ready.
;;; [#f #t] => no more.
(define (wait-any . maybe-flags)
(let ((table-hit (lambda (proc) (values proc (proc:%status proc)))) ; Hit.
(flags (:optional maybe-flags 0)))
(cond ((get-reaped-proc!) => table-hit) ; Check internal table.
(else ; Really wait.
(let lp ()
(receive (err pid status)
(%wait-pid/errno -1 flags)
;; We got an error of some sort. Check the reaped table
;; one last time before really deciding there was an error.
(cond (err (cond ((get-reaped-proc!) => table-hit)
((= err errno/child) (values #f #t)) ; No more.
((= err errno/intr) (lp))
(else (errno-error err %wait-any flags))))
;; None ready. Check the reaped-proc table once more
;; before reporting this.
((zero? pid)
(cond ((get-reaped-proc!) => table-hit)
(else (values #f #f)))) ; None ready.
;; Win.
(else (let ((proc (pid->proc pid)))
(cache-wait-status proc status)
(values proc status))))))))))
;;; (wait-process-group [proc-group flags]) => [proc status]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; [#f #f] => non-blocking, none ready.
;;; [#f #t] => no more.
;;;
;;;
;;; If you are doing process-group waits, you do *not* want to use
;;; early autoreaping, since the reaper loses process-group information.
(define (wait-process-group . args)
(let-optionals args ((proc-group 0) (flags 0))
(let ((proc-group (cond ((integer? proc-group) proc-group)
((proc? proc-group) (proc:pid proc-group))
(else (error "Illegal argument" wait-process-group
proc-group)))))
(receive (pid status) (%wait-process-group proc-group flags)
(if pid
(let ((proc (pid->proc pid)))
(cache-wait-status proc status)
(values proc status))
(values pid status)))))) ; pid = #f -- Empty poll.
;;; (%wait-any flags) (%wait-pid pid flags) (%wait-process-group pgrp flags)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Direct interfaces to waitpid(2) call.
;;; [#f #f] means no processes ready on a non-blocking wait.
;;; [#f #t] means no waitable process on wait-any.
(define (%wait-pid pid flags)
(let lp ()
(receive (err pid status) (%wait-pid/errno pid flags)
(cond ((not err) (and (not (zero? pid)) status)) ; pid=0 => none ready.
((= err errno/intr) (lp))
(else (errno-error err %wait-pid pid flags))))))
(define (%wait-any flags)
(let lp ()
(receive (err pid status) (%wait-pid/errno -1 flags)
(cond (err (cond ((= err errno/child) (values #f #t)) ; No more.
((= err errno/intr) (lp))
(else (errno-error err %wait-any flags))))
((zero? pid) (values #f #f)) ; None ready.
(else (values pid status))))))
(define (%wait-process-group pgrp flags)
(let lp ()
(receive (err pid status) (%wait-pid/errno (- pgrp) flags)
(cond (err (cond ((= err errno/child) (values #f #t)) ; No more.
((= err errno/intr) (lp))
(else (errno-error err %wait-process-group pgrp flags))))
((zero? pid) (values #f #f)) ; None ready.
(else (values pid status))))))
;;; Reaped process table
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; We keep track of procs that have been reaped but not yet waited on by
;;; the user's code. These proces are eligible for return by WAIT-ANY.
;;; We keep track of these so that WAIT-ANY will hand them out exactly once.
;;; Whenever WAIT, WAIT-ANY, WAIT-PROCESS-GROUP waits on a process to exit,
;;; it removes the process from this table if it's in it.
;;; This code is bogus -- we use weak pointers. We need populations that
;;; support deletion or filtering.
(define reaped-procs '()) ; Reaped, but not yet waited.
(define (filter-weak-ptr-list pred lis)
(reverse (reduce (lambda (result wptr)
(let ((val (weak-pointer-ref wptr)))
(if (and val (pred val))
(cons wptr result)
result)))
'()
lis)))
;;; Add a newly-reaped proc to the list.
(define (add-reaped-proc! pid status)
((with-enabled-interrupts 0
(cond ((maybe-pid->proc pid) =>
(lambda (proc)
(set-proc:%status proc status)
(set! reaped-procs (cons (make-weak-pointer proc)
reaped-procs))
(lambda () #f)))
(else (lambda () ; Do this w/interrupts enabled.
(warn "Exiting child pid has no proc object." pid status)))))))
;;; Pop one off the list.
(define (get-reaped-proc!)
(with-enabled-interrupts 0
(let grp! ()
(and (pair? reaped-procs)
(let ((proc (weak-pointer-ref (car reaped-procs))))
(set! reaped-procs (cdr reaped-procs))
(or proc (grp!)))))))
;;; PROC no longer eligible to be in the list. Delete it.
(define (mark-proc-waited! proc)
(with-enabled-interrupts 0
(set! reaped-procs
(filter-weak-ptr-list (lambda (elt) (not (eq? proc elt)))
reaped-procs))))
;;; The mark-proc-waited! machinery above is a crock. It is inefficient --
;;; we should have a flag in the proc saying if it's eligible for a WAIT-ANY.
;;; Starts off #t, changes to #f after a wait. On a #t->#f transition, we
;;; delete it from the WAIT-ANY population. Right now, every time the user
;;; waits on the proc, we re-delete it from the population -- which is
;;; a no-op after the first time.

181
scsh/rw.old.scm
View File

@ -1,181 +0,0 @@
;;; Basic read and write
;;; Copyright (c) 1993 by Olin Shivers.
;;; Note: read ops should check to see if their string args are mutable.
(define (bogus-substring-spec? s start end)
(or (< start 0)
(< (string-length s) end)
(< end start)))
;;; Best-effort/forward-progress reading
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (generic-read-string!/partial s start end reader source)
(if (bogus-substring-spec? s start end)
(error "Bad substring indices" reader source s start end))
(if (= start end) 0 ; Vacuous request.
(let loop ()
(receive (err nread) (reader s start end source)
(cond ((not err) (and (not (zero? nread)) nread))
((= err errno/intr) (loop))
((or (= err errno/wouldblock) ; No forward-progess here.
(= err errno/again))
0)
(else (errno-error err reader s start start end source)))))))
(define (read-string!/partial s . args)
(let-optionals args ((fd/port (current-input-port))
(start 0)
(end (string-length s)))
(cond ((integer? fd/port)
(generic-read-string!/partial s start end
read-fdes-substring!/errno fd/port))
((fdport? fd/port)
(generic-read-string!/partial s start end
read-fdport*-substring!/errno
(port-data fd/port)))
(else ; Hack it for base S48 ports
;; This case is a little gross in order to get
;; the forward-progress guarantee and handle non-blocking i/o.
;; Unix sux. So do low-level Scheme looping constructs.
(if (>= start end) 0
(let lp ((i start))
(let ((c (with-errno-handler
((err data) ((errno/wouldblock errno/again) #f))
(read-char fd/port))))
(cond ((not c) (- i start)) ; non-blocking i/o bailout
((eof-object? c)
(let ((nread (- i start)))
(and (not (zero? nread)) nread)))
(else
(string-set! s i c)
(let ((i (+ i 1)))
(if (or (= i end) (not (char-ready? fd/port)))
(- i start)
(lp i))))))))))))
(define (read-string/partial len . maybe-fd/port)
(let* ((s (make-string len))
(fd/port (:optional maybe-fd/port (current-input-port)))
(nread (read-string!/partial s fd/port 0 len)))
(cond ((not nread) #f) ; EOF
((= nread len) s)
(else (substring s 0 nread)))))
;;; Persistent reading
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (generic-read-string! s start end reader source)
(if (bogus-substring-spec? s start end)
(error "Bad substring indices" reader source s start end))
(let loop ((i start))
(if (>= i end) (- i start)
(receive (err nread) (reader s i end source)
(cond (err (if (= err errno/intr) (loop i)
;; Give info on partially-read data in error packet.
(errno-error err reader
s start i end source)))
((zero? nread) ; EOF
(let ((result (- i start)))
(and (not (zero? result)) result)))
(else (loop (+ i nread))))))))
(define (read-string! s . args)
(let-optionals args ((fd/port (current-input-port))
(start 0)
(end (string-length s)))
(cond ((integer? fd/port)
(generic-read-string! s start end
read-fdes-substring!/errno fd/port))
((fdport? fd/port)
(generic-read-string! s start end
read-fdport*-substring!/errno
(port-data fd/port)))
;; Hack it
(else (let lp ((i start))
(if (= i end) (- end start)
(let ((c (read-char fd/port)))
(if (eof-object? c)
(let ((nread (- i start)))
(and (not (zero? nread)) nread))
(begin (string-set! s i c)
(lp (+ i 1)))))))))))
(define (read-string len . maybe-fd/port)
(let* ((s (make-string len))
(fd/port (:optional maybe-fd/port (current-input-port)))
(nread (read-string! s fd/port 0 len)))
(cond ((not nread) #f) ; EOF
((= nread len) s)
(else (substring s 0 nread)))))
;;; Best-effort/forward-progress writing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Non-blocking output to a buffered port is not defined.
(define (generic-write-string/partial s start end writer target)
(if (bogus-substring-spec? s start end)
(error "Bad substring indices" writer s start end target))
(if (= start end) 0 ; Vacuous request.
(let loop ()
(receive (err nwritten) (writer s start end target)
(cond ((not err) nwritten)
((= err errno/intr) (loop))
((or (= err errno/again) (= err errno/wouldblock)) 0)
(else (errno-error err writer
s start start end target)))))))
(define (write-string/partial s . args)
(let-optionals args ((fd/port (current-output-port))
(start 0)
(end (string-length s)))
(cond ((integer? fd/port)
(generic-write-string/partial s start end
write-fdes-substring/errno fd/port))
((fdport? fd/port)
(generic-write-string/partial s start end
write-fdport*-substring/errno
(port-data fd/port)))
(else (display (substring s start end) fd/port))))) ; hack
;;; Persistent writing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (generic-write-string s start end writer target)
(if (bogus-substring-spec? s start end)
(error "Bad substring indices" writer s start end target))
(let loop ((i start))
(if (< i end)
(receive (err nwritten) (writer s i end target)
(cond ((not err) (loop (+ i nwritten)))
((= err errno/intr) (loop i))
(else (errno-error err writer
s start i end target)))))))
(define (write-string s . args)
(let-optionals args ((fd/port (current-output-port))
(start 0)
(end (string-length s)))
(cond ((integer? fd/port)
(generic-write-string s start end
write-fdes-substring/errno fd/port))
((fdport? fd/port)
(generic-write-string s start end
write-fdport*-substring/errno
(port-data fd/port)))
(else (display (substring s start end) fd/port))))) ; hack

225
scsh/sighandlers.old.scm
View File

@ -1,225 +0,0 @@
;;; Copyright (c) 1993 by Olin Shivers.
;;; Signal handler system
;;; The principal trickiness here is that we have to interface to Unix signals
;;; *through* an intermediate interface, the S48 vm's idea of interrupts.
;;; So there is a difference between delivering a signal to the underlying
;;; Unix process and delivering it to the program that runs on the VM.
;;;
;;; One effect is that we have two separate codes for the same thing -- the
;;; Unix signal code, and the S48 interrupt value. E.g., SIGNAL/TSTP and
;;; INTERRUPT/TSTP.
;;; These system calls can return EINTR or restart. In order for the S48 vm's
;;; interrupt system to detect a signal and invoke the handler, they *must*
;;; return EINTR, and this must cause a return from C to Scheme.
;;;
;;; open close dup2 accept connect
;;; read recv recvfrom recvmsg
;;; write send sendto sendmsg
;;; select
;;; wait
;;; fcntl* ioctl
;;; sigsuspend
;;; HP-UX, but I don't use: poll lockf msem_lock msgsnd msgrcv semop
;;;
;;; * Only during a F_SETLKW
;;;
;;; From rts/interrupt.scm (package interrupts, interface interrupts-interface)
;;; WITH-INTERRUPTS INTERRUPT-HANDLERS SET-ENABLED-INTERRUPTS !
;;; ENABLED-INTERRUPTS
;;; Must define WITH-INTERRUPTS* and WITH-INTERRUPTS.
(foreign-source
"extern int errno;"
""
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
"#include \"sighandlers1.h\""
"" "")
;;; Map a Unix async signal to its S48 interrupt value.
;;; -1 => Not defined.
(define-foreign %signal->interrupt (sig2interrupt (integer sig))
integer)
(define (signal->interrupt sig)
(let ((int (%signal->interrupt sig)))
(if (>= int 0) int
(error "Unix signal has no Scheme 48 interrupt." sig))))
(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)))
;;; I'm trying to be consistent about the ! suffix -- I don't use it
;;; when frobbing process state. This is not a great rule; perhaps I
;;; should change it.
(define set-enabled-interrupts set-enabled-interrupts!)
(define-simple-syntax (with-enabled-interrupts mask body ...)
(with-interrupts mask (lambda () body ...)))
(define with-enabled-interrupts* with-interrupts)
(define interrupt/alarm (enum interrupt alarm))
(define interrupt/keyboard (enum interrupt keyboard))
;(define interrupt/memory-shortage (enum interrupt memory-shortage))
(define interrupt/chld (enum interrupt chld))
(define interrupt/cont (enum interrupt cont))
(define interrupt/hup (enum interrupt hup))
(define interrupt/quit (enum interrupt quit))
(define interrupt/term (enum interrupt term))
(define interrupt/tstp (enum interrupt tstp))
(define interrupt/usr1 (enum interrupt usr1))
(define interrupt/usr2 (enum interrupt usr2))
(define interrupt/info (enum interrupt info))
(define interrupt/io (enum interrupt io))
(define interrupt/poll (enum interrupt poll))
(define interrupt/prof (enum interrupt prof))
(define interrupt/pwr (enum interrupt pwr))
(define interrupt/urg (enum interrupt urg))
(define interrupt/vtalrm (enum interrupt vtalrm))
(define interrupt/winch (enum interrupt winch))
(define interrupt/xcpu (enum interrupt xcpu))
(define interrupt/xfsz (enum interrupt xfsz))
(define interrupt/int interrupt/keyboard)
(define interrupt/alrm interrupt/alarm)
;;; Get/Set signal handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; When you set a signal's handler to "default," if the default for that
;;; signal is something other than "ignore," we actually install this guy.
;;; When he is called by the S48 interrupt system, he'll magically make
;;; the default action happen (by calling C code that *really* sets the
;;; handler to SIGDFL, and then re-sending the signal). This basically
;;; terminates the process, since if the default isn't "ignore," it's always
;;; "terminate" of some kind. Doing it this way means the exit code given
;;; to our waiting parent proc correctly reflects how we died, and also
;;; makes the core dump happen if it should. Details, details.
(define-foreign %do-default-sigaction (do_default_sigaction (fixnum signal))
ignore)
(define default-int-handler-vec
;; Non-Unix-signal interrupts just get their default values from
;; the current value of I-H.
(let ((v (copy-vector interrupt-handlers)))
(do ((sig 31 (- sig 1))) ; For each Unix signal
((< sig 0)) ; make & install a default
(let ((i (%signal->interrupt sig))) ; signal handler.
(if (>= i 0) ; Don't mess with non-signal interrupts.
(vector-set! v i (if (memv sig signals-ignored-by-default)
(lambda (enabled-interrupts) #f)
(lambda (enabled-interrupts)
(%do-default-sigaction sig)))))))
v))
;;; HANDLER is #f (ignore), #t (default), or a procedure taking an integer
;;; argument. The interrupt is delivered to a procedure by (1) setting the
;;; ENABLED-INTERRUPTS register to 0 (i.e., blocking all interrupts), and (2)
;;; applying the procedure to the previous value of the ENABLED-INTERRUPTS
;;; register. If the procedure returns normally, the ENABLED-INTERRUPTS
;;; register will be restored to its previous value.
;;; This handler does nothing -- used when the handler is #f.
(define (noop-sig-handler enabled-interrupts) #f)
(define (set-interrupt-handler int handler)
(let ((ohandler (interrupt-handler int)))
(vector-set! interrupt-handlers int
(case handler
((#t) (vector-ref default-int-handler-vec int))
((#f) noop-sig-handler)
(else handler)))
(cond ((and (not handler) ohandler ; Toggling from something
(int->signal int)) => ; to ignored.
(lambda (sig)
(%set-unix-signal-handler sig 0)))
((and handler (not ohandler) ; Toggling from ignored
(int->signal int)) => ; to something.
(lambda (sig)
(%set-unix-signal-handler sig 2))))
ohandler))
(define (interrupt-handler int)
(let ((handler (vector-ref interrupt-handlers int)))
(cond ((eq? handler (vector-ref default-int-handler-vec int)) #t)
((eq? handler noop-sig-handler) #f)
(else handler))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set the Unix signal handler. One doesn't usually use this; one usually
;;; uses the S48 VM's interrupt system.
;;; HANDLER-CODE: 0 => ignore, 1 => default, 2 => S48 VM
;;; Returns equivalent code, additionally 3 => other handler.
;;; Raises an error exception if there's a problem.
(define (%set-unix-signal-handler sig handler-code)
(check-arg (lambda (x) (and (integer? sig) (< 0 sig 32)))
sig
%set-unix-signal-handler)
(check-arg (lambda (x) (and (integer? handler-code) (<= 0 handler-code 2)))
handler-code
%set-unix-signal-handler)
(let retry ()
(receive (err old-hc old-flags)
(%%set-unix-signal-handler sig handler-code 0)
(cond ((not err) old-hc)
((= err errno/intr) (retry))
(else (errno-error err %set-unix-signal-handler sig handler-code))))))
(define-foreign %%set-unix-signal-handler
(scsh_set_sig (fixnum sig) (fixnum hc) (fixnum flags))
desc ; #f or errno
integer ; previous handler-code
integer) ; previous handler flags
(define (%unix-signal-handler sig)
(check-arg (lambda (x) (and (integer? sig) (< 0 sig 32)))
sig
%unix-signal-handler)
(let retry ()
(receive (err hc flags) (%%unix-signal-handler sig)
(cond ((not err) hc)
((= err errno/intr) (retry))
(else (errno-error err %unix-signal-handler sig))))))
(define-foreign %%unix-signal-handler (scsh_get_sig (fixnum sig))
desc ; #f or errno
integer ; previous handler-code
integer) ; previous handler flags
(define-foreign %install-unix-scsh-handlers (install_scsh_handlers) ignore)
(define-foreign %%get-int-handlers (get_int_handlers) desc)
(define (%install-scsh-handlers)
(do ((sig 32 (- sig 1)))
((< sig 0))
(let ((i (%signal->interrupt sig)))
(if (not (or (= i -1)
(= sig signal/int) ; Leave ^c and
(= sig signal/alrm))) ; alarm handlers alone.
(vector-set! interrupt-handlers i
(vector-ref default-int-handler-vec i))))))
;;; I am ashamed to say the 33 below is completely bogus.
;;; What we want is a value that is 1 + max interrupt value.
(define int->sig-vec
(let ((v (make-vector 33 #f)))
(do ((sig 32 (- sig 1)))
((< sig 0))
(let ((i (%signal->interrupt sig)))
(if (not (= i -1)) (vector-set! v i sig))))
v))
(define (int->signal i) (and (<= 0 i 32) (vector-ref int->sig-vec i)))