returned mode information is passed back.
/* -*-C-*-
-$Id: prosio.c,v 1.21 2003/01/22 18:42:26 cph Exp $
+$Id: prosio.c,v 1.22 2003/01/22 19:46:01 cph Exp $
Copyright 1987,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1996,1997,2001,2003 Massachusetts Institute of Technology
select_registry_t r = (arg_select_registry (1));
unsigned int rl = (OS_select_registry_length (r));
int blockp = (BOOLEAN_ARG (2));
- SCHEME_OBJECT vr = (VECTOR_ARG (3));
- SCHEME_OBJECT vw = (VECTOR_ARG (4));
+ SCHEME_OBJECT vfd = (VECTOR_ARG (3));
+ SCHEME_OBJECT vmode = (VECTOR_ARG (4));
int result;
- if ((VECTOR_LENGTH (vr)) < (rl + 1))
+ if ((VECTOR_LENGTH (vfd)) < rl)
error_bad_range_arg (3);
- if ((VECTOR_LENGTH (vw)) < (rl + 1))
+ if ((VECTOR_LENGTH (vmode)) < rl)
error_bad_range_arg (4);
result = (OS_test_select_registry (r, blockp));
if (result > 0)
{
unsigned int i = 0;
- unsigned int ir = 1;
- unsigned int iw = 1;
+ unsigned int iv = 0;
while (i < rl)
{
int fd;
OS_select_registry_result (r, i, (&fd), (&mode));
if (mode > 0)
{
- SCHEME_OBJECT sfd = (long_to_integer (fd));
- if (((mode & SELECT_MODE_READ) != 0)
- || ((mode & SELECT_MODE_ERROR) != 0)
- || ((mode & SELECT_MODE_HUP) != 0))
- {
- VECTOR_SET (vr, ir, sfd);
- ir += 1;
- }
- if ((mode & SELECT_MODE_WRITE) != 0)
- {
- VECTOR_SET (vw, iw, sfd);
- iw += 1;
- }
+ VECTOR_SET (vfd, iv, (long_to_integer (fd)));
+ VECTOR_SET (vmode, iv, (ulong_to_integer (mode)));
+ iv += 1;
}
i += 1;
}
- VECTOR_SET (vr, 0, (ulong_to_integer (ir - 1)));
- VECTOR_SET (vw, 0, (ulong_to_integer (iw - 1)));
}
PRIMITIVE_RETURN (long_to_integer (result));
}
#| -*-Scheme-*-
-$Id: io.scm,v 14.68 2003/01/22 18:43:05 cph Exp $
+$Id: io.scm,v 14.69 2003/01/22 19:46:32 cph Exp $
Copyright 1986,1987,1988,1990,1991,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1998,1999,2000,2001 Massachusetts Institute of Technology
descriptor
block?
(encode-select-registry-mode mode))))
- (if (>= result 0)
- (cond ((fix:= 8 (fix:and 8 result)) 'HANGUP)
- ((fix:= 4 (fix:and 4 result)) 'ERROR)
- (else
- (if (fix:= 1 (fix:and 1 result))
- (if (fix:= 2 (fix:and 2 result)) 'READ/WRITE 'READ)
- (if (fix:= 2 (fix:and 2 result)) 'WRITE #f))))
- (case result
- ((-1) 'INTERRUPT)
- ((-2)
+ (cond ((>= result 0) (decode-select-registry-mode result))
+ ((= result -1) 'INTERRUPT)
+ ((= result -2)
(subprocess-global-status-tick)
'PROCESS-STATUS-CHANGE)
(else
- (error "Illegal result from TEST-SELECT-DESCRIPTOR:" result))))))
+ (error "Illegal result from TEST-SELECT-DESCRIPTOR:" result)))))
(define (encode-select-registry-mode mode)
(case mode
((WRITE) 2)
((READ/WRITE) 3)
(else (error:bad-range-argument mode 'ENCODE-SELECT-REGISTRY-MODE))))
+
+(define (decode-select-registry-mode mode)
+ (cond ((fix:= 8 (fix:and 8 mode)) 'HANGUP)
+ ((fix:= 4 (fix:and 4 mode)) 'ERROR)
+ (else
+ (if (fix:= 1 (fix:and 1 mode))
+ (if (fix:= 2 (fix:and 2 mode)) 'READ/WRITE 'READ)
+ (if (fix:= 2 (fix:and 2 mode)) 'WRITE #f)))))
\f
(define (test-select-registry registry block?)
- (receive (vr vw) (allocate-select-registry-result-vectors registry)
+ (receive (vfd vmode) (allocate-select-registry-result-vectors registry)
(let ((result
((ucode-primitive test-select-registry 4)
(select-registry-handle registry)
block?
- vr
- vw)))
+ vfd
+ vmode)))
(if (> result 0)
- (cons vr vw)
(begin
- (deallocate-select-registry-result-vectors vr vw)
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i result))
+ (vector-set! vmode i
+ (decode-select-registry-mode (vector-ref vmode i))))
+ (vector result vfd vmode))
+ (begin
+ (deallocate-select-registry-result-vectors vfd vmode)
(cond ((= 0 result) #f)
((= -1 result) 'INTERRUPT)
((= -2 result)
rl))))
(let loop ((rv select-registry-result-vectors))
(if (pair? rv)
- (let ((vr (caar rv))
- (vw (cdar rv)))
- (if (and vr (fix:< n (vector-length vr)))
+ (let ((vfd (caar rv))
+ (vmode (cdar rv)))
+ (if (and vfd (fix:<= n (vector-length vfd)))
(begin
(set-car! (car rv) #f)
(set-cdr! (car rv) #f)
(set-interrupt-enables! interrupt-mask)
- (values vr vw))
+ (values vfd vmode))
(loop (cdr rv))))
(let loop ((m 16))
(if (fix:< n m)
(values (make-vector m) (make-vector m)))
(loop (fix:* m 2)))))))))
-(define (deallocate-select-registry-result-vectors vr vw)
+(define (deallocate-select-registry-result-vectors vfd vmode)
(let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
(let loop ((rv select-registry-result-vectors))
(if (pair? rv)
(if (caar rv)
(loop (cdr rv))
(begin
- (set-car! (car rv) vr)
- (set-cdr! (car rv) vw)))
+ (set-car! (car rv) vfd)
+ (set-cdr! (car rv) vmode)))
(set! select-registry-result-vectors
- (cons (cons vr vw) select-registry-result-vectors))))
+ (cons (cons vfd vmode) select-registry-result-vectors))))
(set-interrupt-enables! interrupt-mask)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: thread.scm,v 1.37 2003/01/22 02:05:41 cph Exp $
+$Id: thread.scm,v 1.38 2003/01/22 19:46:40 cph Exp $
Copyright 1991,1992,1993,1998,1999,2001 Massachusetts Institute of Technology
Copyright 2003 Massachusetts Institute of Technology
(wait-for-io)))))))
(define (signal-select-result result)
- (cond ((pair? result)
- (signal-io-thread-events (car result) (cdr result)))
+ (cond ((vector? result)
+ (signal-io-thread-events (vector-ref result 0)
+ (vector-ref result 1)
+ (vector-ref result 2)))
((eq? 'PROCESS-STATUS-CHANGE result)
- (signal-io-thread-events '#(1 PROCESS-STATUS-CHANGE) '#(0)))))
+ (signal-io-thread-events 1
+ '#(PROCESS-STATUS-CHANGE)
+ '#(READ)))))
\f
(define (block-on-io-descriptor descriptor mode)
(without-interrupts
(%deregister-io-thread-event registration-1)))))))
(define (permanently-register-io-thread-event descriptor mode thread event)
+ (guarantee-select-mode mode 'PERMANENTLY-REGISTER-IO-THREAD-EVENT)
(guarantee-thread thread 'PERMANENTLY-REGISTER-IO-THREAD-EVENT)
(without-interrupts
(lambda ()
(%register-io-thread-event descriptor mode thread event #t #f))))
(define (register-io-thread-event descriptor mode thread event)
+ (guarantee-select-mode mode 'REGISTER-IO-THREAD-EVENT)
(guarantee-thread thread 'REGISTER-IO-THREAD-EVENT)
(without-interrupts
(lambda ()
(%maybe-toggle-thread-timer))))
(define (deregister-io-descriptor-events descriptor mode)
+ (guarantee-select-mode mode 'DEREGISTER-IO-DESCRIPTOR-EVENTS)
(without-interrupts
(lambda ()
(let loop ((dentry io-registrations))
(not (tentry/permanent? tentry))))
(cons tentry tentries)
tentries))))))))
+
+(define (guarantee-select-mode mode procedure)
+ (if (not (memq mode '(READ WRITE READ-WRITE)))
+ (error:wrong-type-argument mode "select mode" procedure)))
\f
-(define (signal-io-thread-events vr vw)
+(define (signal-io-thread-events n vfd vmode)
(let ((search
- (lambda (descriptor v)
- (let ((n (vector-ref v 0)))
- (let loop ((i 1))
- (and (fix:<= i n)
- (or (eqv? descriptor (vector-ref v i))
- (loop (fix:+ i 1)))))))))
- (let loop ((dentry io-registrations) (events '()))
- (if dentry
- (let ((mode
- (let ((descriptor (dentry/descriptor dentry))
- (mode (dentry/mode dentry)))
- (case mode
- ((READ) (and (search descriptor vr) 'READ))
- ((WRITE) (and (search descriptor vw) 'WRITE))
- ((READ/WRITE)
- (if (search descriptor vr)
- (if (search descriptor vw) 'READ/WRITE 'READ)
- (if (search descriptor vw) 'WRITE #f)))
- (else #f)))))
- (if mode
- (let ((next (dentry/next dentry))
- (tentry (dentry/first-tentry dentry)))
- (let ((events
- (cons (cons (tentry/thread tentry)
- (let ((e (tentry/event tentry)))
- (and e
- (lambda () (e mode)))))
- events)))
- (if (tentry/permanent? tentry)
- (move-tentry-to-back! tentry)
- (delete-tentry! tentry))
- (loop next events)))
- (loop (dentry/next dentry) events)))
+ (lambda (descriptor predicate)
+ (let scan-dentries ((dentry io-registrations))
+ (and dentry
+ (if (and (eqv? descriptor (dentry/descriptor dentry))
+ (predicate (dentry/mode dentry)))
+ dentry
+ (scan-dentries (dentry/next dentry))))))))
+ (let loop ((i 0) (events '()))
+ (if (fix:< i n)
+ (let ((descriptor (vector-ref vfd i))
+ (mode (vector-ref vmode i)))
+ (let ((dentry
+ (search
+ descriptor
+ (case mode
+ ((READ) (lambda (mode) (memq mode '(READ READ/WRITE))))
+ ((WRITE) (lambda (mode) (memq mode '(WRITE READ/WRITE))))
+ ((READ/WRITE) (lambda (mode) mode))
+ ((ERROR HANGUP) (lambda (mode) mode #t))
+ (else (error "Illegal mode:" mode))))))
+ (let ((tentry (dentry/first-tentry dentry)))
+ (let ((events
+ (cons (cons (tentry/thread tentry)
+ (let ((e (tentry/event tentry)))
+ (and e
+ (lambda () (e mode)))))
+ events)))
+ (if (tentry/permanent? tentry)
+ (move-tentry-to-back! tentry)
+ (delete-tentry! tentry))
+ (loop (fix:+ i 1) events)))))
(do ((events events (cdr events)))
((not (pair? events)))
(%signal-thread-event (caar events) (cdar events)))))))
projects / mit-scheme.git / commitdiff