later.
#| -*-Scheme-*-
-$Id: dosprm.scm,v 1.44 2002/11/20 19:46:19 cph Exp $
+$Id: dosprm.scm,v 1.45 2003/01/22 02:04:55 cph Exp $
-Copyright (c) 1992-2000 Massachusetts Institute of Technology
+Copyright 1992,1993,1994,1995,1996,1998 Massachusetts Institute of Technology
+Copyright 1999,2000,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(close-port port)
(set! port #f)
unspecific))))))))
-\f
-(define (select-internal console? handles block?)
- (let* ((nt/qs-allinput #xff)
- (select
- (if console?
- (lambda (period)
- ((ucode-primitive nt:msgwaitformultipleobjects 4)
- handles #f period nt/qs-allinput))
- (lambda (period)
- ((ucode-primitive nt:waitformultipleobjects 3)
- handles #f period)))))
- (if (not block?)
- (select 0)
- (let loop ()
- (let ((res (select 20)))
- (if (zero? res)
- (loop)
- res))))))
(define console-channel-descriptor)
(define (cache-console-channel-descriptor!)
(set! console-channel-descriptor -1)
- unspecific)
-
-(define (select-descriptor descriptor block?)
- (define (select-result result)
- (cond ((fix:> result 0)
- 'INPUT-AVAILABLE)
- ((fix:< result 0)
- (error "Illegal result from select-internal" result))
- (else
- #f)))
-
- (select-result
- (if (= descriptor console-channel-descriptor)
- (select-internal true '#() block?)
- (select-internal false (vector descriptor) block?))))
-\f
-(define-structure (nt-select-registry
- (conc-name nt-select-registry/)
- (constructor nt-select-registry/make))
- console
- descriptors)
-
-(define-integrable (find-descriptor df dl)
- (list-search-positive dl
- (lambda (d)
- (= d df))))
-
-(define (make-select-registry . descriptors)
- (cond ((find-descriptor console-channel-descriptor descriptors)
- => (lambda (ccd)
- (nt-select-registry/make console-channel-descriptor
- (delq! ccd descriptors))))
- (else
- (nt-select-registry/make false descriptors))))
-
-(define (add-to-select-registry! registry descriptor)
- (cond ((= descriptor console-channel-descriptor)
- (set-nt-select-registry/console! registry console-channel-descriptor))
- ((not (find-descriptor descriptor
- (nt-select-registry/descriptors registry)))
- (set-nt-select-registry/descriptors!
- registry
- (cons descriptor (nt-select-registry/descriptors registry))))))
-
-(define (remove-from-select-registry! registry descriptor)
- (cond ((= descriptor console-channel-descriptor)
- (set-nt-select-registry/console! registry false))
- ((find-descriptor descriptor (nt-select-registry/descriptors registry))
- => (lambda (dr)
- (set-nt-select-registry/descriptors!
- registry
- (delq! dr (nt-select-registry/descriptors registry)))))))
-
-(define (select-registry-test registry block?)
- (let* ((handles (list->vector (nt-select-registry/descriptors registry)))
- (result (select-internal (nt-select-registry/console registry)
- handles
- block?)))
- (cond ((fix:< result 0)
- (error "Illegal result from select-internal" result))
- ((fix:= result 0)
- #f)
- ((fix:> result (vector-length handles))
- (list (nt-select-registry/console registry)))
- (else
- (list (vector-ref handles (fix:- result 1)))))))
\ No newline at end of file
+ unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Id: io.scm,v 14.66 2002/12/09 05:40:04 cph Exp $
+$Id: io.scm,v 14.67 2003/01/22 02:05:02 cph Exp $
-Copyright (c) 1988-2002 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1990,1991,1993 Massachusetts Institute of Technology
+Copyright 1994,1995,1998,1999,2000,2001 Massachusetts Institute of Technology
+Copyright 2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
\f
(define open-channels-list)
(define open-directories)
-(define have-select?)
(define (initialize-package!)
(set! open-channels-list (list 'OPEN-CHANNELS-LIST))
(add-gc-daemon! close-lost-open-files-daemon)
(set! open-directories
(make-gc-finalizer (ucode-primitive new-directory-close 1)))
- (set! have-select? ((ucode-primitive have-select? 0)))
- (add-event-receiver! event:after-restore primitive-io/reset!))
+ (add-event-receiver! event:after-restore
+ (lambda ()
+ (close-all-open-channels-internal (lambda (ignore) ignore))))
+ (initialize-select-registry!))
(define-structure (channel (constructor %make-channel))
;; This structure serves two purposes. First, because a descriptor
(system-pair-set-car! p channel)
(set-cdr! open-channels-list (cons p (cdr open-channels-list)))))
channel))
-
+\f
(define (descriptor->channel descriptor)
(let loop ((channels (cdr open-channels-list)))
(and (not (null? channels))
(or (eq? 'TERMINAL type)
(eq? 'UNIX-PTY-MASTER type)
(eq? 'OS/2-CONSOLE type))))
-\f
+
(define (channel-close channel)
(without-interrupts
(lambda ()
(define-integrable (channel-closed? channel)
(not (channel-descriptor channel)))
-
+\f
(define (close-all-open-files)
(close-all-open-channels channel-type=file?))
result
(loop (cdr l) (cons (system-pair-car (car l)) result)))))))
-(define (primitive-io/reset!)
- ;; This is invoked after disk-restoring.
- ;; It "cleans" the new runtime system.
- (close-all-open-channels-internal (lambda (ignore) ignore))
- (set! have-select? ((ucode-primitive have-select? 0)))
- unspecific)
-
(define (close-all-open-channels-internal action)
(without-interrupts
(lambda ()
(lambda ()
(let ((do-test
(lambda (k)
- (let ((result (test-for-input-on-channel channel)))
+ (let ((result (test-for-io-on-channel channel 'READ)))
(case result
- ((INPUT-AVAILABLE)
+ ((READ)
(do-read))
((PROCESS-STATUS-CHANGE)
(handle-subprocess-status-change)
(or (channel-read channel buffer start end)
(loop))))
-(define-integrable (test-for-input-on-channel channel)
- (test-for-input-on-descriptor (channel-descriptor-for-select channel)
- (channel-blocking? channel)))
+(define (test-for-io-on-channel channel mode)
+ (test-for-io-on-descriptor (channel-descriptor-for-select channel)
+ (channel-blocking? channel)
+ mode))
-(define (test-for-input-on-descriptor descriptor block?)
+(define (test-for-io-on-descriptor descriptor block? mode)
(if block?
- (or (select-descriptor descriptor #f)
- (block-on-input-descriptor descriptor))
- (select-descriptor descriptor #f)))
+ (or (test-select-descriptor descriptor #f mode)
+ (block-on-io-descriptor descriptor mode))
+ (test-select-descriptor descriptor #f mode)))
(define-integrable (channel-descriptor-for-select channel)
((ucode-primitive channel-descriptor 1) (channel-descriptor channel)))
(if (fix:> contents-size (string-length string))
(input-buffer/set-size buffer contents-size))
(substring-move! contents 0 contents-size string 0)
- (input-buffer/after-fill! buffer contents-size)))))))
\ No newline at end of file
+ (input-buffer/after-fill! buffer contents-size)))))))
+\f
+;;;; Select registry
+
+(define have-select?)
+(define select-registry-finalizer)
+(define select-registry-result-vectors)
+
+(define (initialize-select-registry!)
+ (set! have-select? ((ucode-primitive have-select? 0)))
+ (set! select-registry-finalizer
+ (make-gc-finalizer (ucode-primitive deallocate-select-registry 1)))
+ (let ((reset-rv!
+ (lambda ()
+ (set! select-registry-result-vectors '())
+ unspecific)))
+ (reset-rv!)
+ (add-event-receiver! event:after-restart reset-rv!))
+ (add-event-receiver! event:after-restore
+ (lambda ()
+ (set! have-select? ((ucode-primitive have-select? 0)))
+ unspecific)))
+
+(define-structure (select-registry
+ (constructor %make-select-registry (handle)))
+ handle
+ (length #f))
+
+(define (make-select-registry)
+ (without-interrupts
+ (lambda ()
+ (let ((handle ((ucode-primitive allocate-select-registry 0))))
+ (let ((registry (%make-select-registry handle)))
+ (add-to-gc-finalizer! select-registry-finalizer registry handle)
+ registry)))))
+
+(define (add-to-select-registry! registry descriptor mode)
+ ((ucode-primitive add-to-select-registry 3)
+ (select-registry-handle registry)
+ descriptor
+ (encode-select-registry-mode mode))
+ (set-select-registry-length! registry #f))
+
+(define (remove-from-select-registry! registry descriptor mode)
+ ((ucode-primitive remove-from-select-registry 3)
+ (select-registry-handle registry)
+ descriptor
+ (encode-select-registry-mode mode))
+ (set-select-registry-length! registry #f))
+
+(define (test-select-descriptor descriptor block? mode)
+ (let ((result
+ ((ucode-primitive test-select-descriptor 3)
+ descriptor
+ block?
+ (encode-select-registry-mode mode))))
+ (case result
+ ((0) #f)
+ ((1) 'READ)
+ ((2) 'WRITE)
+ ((3) 'READ/WRITE)
+ ((-1) 'INTERRUPT)
+ ((-2)
+ (subprocess-global-status-tick)
+ 'PROCESS-STATUS-CHANGE)
+ (else (error "Illegal result from TEST-SELECT-DESCRIPTOR:" result)))))
+
+(define (encode-select-registry-mode mode)
+ (case mode
+ ((READ) 1)
+ ((WRITE) 2)
+ ((READ/WRITE) 3)
+ (else (error:bad-range-argument mode 'ENCODE-SELECT-REGISTRY-MODE))))
+\f
+(define (test-select-registry registry block?)
+ (receive (vr vw) (allocate-select-registry-result-vectors registry)
+ (let ((result
+ ((ucode-primitive test-select-registry 4)
+ (select-registry-handle registry)
+ block?
+ vr
+ vw)))
+ (if (> result 0)
+ (cons vr vw)
+ (begin
+ (deallocate-select-registry-result-vectors vr vw)
+ (cond ((= 0 result) #f)
+ ((= -1 result) 'INTERRUPT)
+ ((= -2 result)
+ (subprocess-global-status-tick)
+ 'PROCESS-STATUS-CHANGE)
+ (else
+ (error "Illegal result from TEST-SELECT-REGISTRY:"
+ result))))))))
+
+(define (allocate-select-registry-result-vectors registry)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((n
+ (or (select-registry-length registry)
+ (let ((rl
+ ((ucode-primitive select-registry-length 1)
+ (select-registry-handle registry))))
+ (set-select-registry-length! registry rl)
+ 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)))
+ (begin
+ (set-car! (car rv) #f)
+ (set-cdr! (car rv) #f)
+ (set-interrupt-enables! interrupt-mask)
+ (values vr vw))
+ (loop (cdr rv))))
+ (let loop ((m 16))
+ (if (fix:< n m)
+ (begin
+ (set-interrupt-enables! interrupt-mask)
+ (values (make-vector m) (make-vector m)))
+ (loop (fix:* m 2)))))))))
+
+(define (deallocate-select-registry-result-vectors vr vw)
+ (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! select-registry-result-vectors
+ (cons (cons vr vw) select-registry-result-vectors))))
+ (set-interrupt-enables! interrupt-mask)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: ntprm.scm,v 1.38 2002/11/20 19:46:21 cph Exp $
+$Id: ntprm.scm,v 1.39 2003/01/22 02:05:08 cph Exp $
-Copyright (c) 1992-2001 Massachusetts Institute of Technology
+Copyright 1995,1996,1998,1999,2000,2001 Massachusetts Institute of Technology
+Copyright 2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(set! port #f)
unspecific))))))))))
\f
-(define-structure (nt-select-registry (conc-name nt-select-registry/))
- descriptors)
-
-(define (make-select-registry . descriptors)
- (make-nt-select-registry descriptors))
-
-(define (add-to-select-registry! registry descriptor)
- (if (not (memv descriptor (nt-select-registry/descriptors registry)))
- (set-nt-select-registry/descriptors!
- registry
- (cons descriptor (nt-select-registry/descriptors registry)))))
-
-(define (remove-from-select-registry! registry descriptor)
- (set-nt-select-registry/descriptors!
- registry
- (delv! descriptor (nt-select-registry/descriptors registry))))
-
-(define (select-registry-test registry block?)
- (let ((descriptors (list->vector (nt-select-registry/descriptors registry))))
- (let ((result
- ((ucode-primitive nt:waitformultipleobjects 3)
- descriptors #f block?)))
- (cond ((and (fix:<= 0 result) (fix:< result (vector-length descriptors)))
- (list (vector-ref descriptors result)))
- ((fix:= result -1) #f)
- ((fix:= result -2) 'INTERRUPT)
- ((fix:= result -3) 'PROCESS-STATUS-CHANGE)
- (else (error "Illegal result from select-internal:" result))))))
-
-(define (select-descriptor descriptor block?)
- (let ((result
- ((ucode-primitive nt:waitformultipleobjects 3)
- (vector descriptor) #f block?)))
- (case result
- ((0) 'INPUT-AVAILABLE)
- ((-1) #f)
- ((-2) 'INTERRUPT)
- ((-3) 'PROCESS-STATUS-CHANGE)
- (else (error "Illegal result from select-internal:" result)))))
-
-(define console-channel-descriptor)
-
-(define (cache-console-channel-descriptor!)
- (set! console-channel-descriptor
- (channel-descriptor-for-select (tty-input-channel)))
- unspecific)
-\f
;;;; Subprocess/Shell Support
+(define console-channel-descriptor)
(define nt/hide-subprocess-windows?)
(define nt/subprocess-argument-quote-char)
(define nt/subprocess-argument-escape-char)
(let ((reset!
(lambda ()
(reset-environment-variables!)
- (cache-console-channel-descriptor!))))
+ (set! console-channel-descriptor
+ (channel-descriptor-for-select (tty-input-channel)))
+ unspecific)))
(reset!)
(add-event-receiver! event:after-restart reset!))
(set! nt/hide-subprocess-windows? #t)
#| -*-Scheme-*-
-$Id: os2graph.scm,v 1.20 2002/11/20 19:46:21 cph Exp $
+$Id: os2graph.scm,v 1.21 2003/01/22 02:05:15 cph Exp $
-Copyright (c) 1995-2002 Massachusetts Institute of Technology
+Copyright 1995,1996,1997,1999,2000 Massachusetts Institute of Technology
+Copyright 2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(set! graphics-window-icon)
(remove-all-from-gc-finalizer! window-finalizer)
(remove-all-from-gc-finalizer! image-finalizer)
- (deregister-input-thread-event event-previewer-registration)
+ (deregister-io-thread-event event-previewer-registration)
(set! event-previewer-registration #f)
(set! user-event-mask user-event-mask:default)
(flush-queue! user-event-queue)
(begin
(set! event-descriptor (os2win-open-event-qid))
(set! event-previewer-registration
- (permanently-register-input-thread-event
+ (permanently-register-io-thread-event
event-descriptor
+ 'READ
(current-thread)
- read-and-process-event))
+ (lambda (mode)
+ mode
+ (read-and-process-event))))
(set! graphics-window-icon
(os2win-load-pointer HWND_DESKTOP NULLHANDLE IDI_GRAPHICS))))
(open-window descriptor->device
(let loop ()
(if (queue-empty? user-event-queue)
(begin
- (if (eq? 'INPUT-AVAILABLE
- (test-for-input-on-descriptor event-descriptor #t))
+ (if (eq? 'READ
+ (test-for-io-on-descriptor event-descriptor #t 'READ))
(read-and-process-event))
(loop))
(dequeue! user-event-queue))))))
#| -*-Scheme-*-
-$Id: os2prm.scm,v 1.49 2002/11/20 19:46:21 cph Exp $
+$Id: os2prm.scm,v 1.50 2003/01/22 02:05:21 cph Exp $
-Copyright (c) 1994-2001 Massachusetts Institute of Technology
+Copyright 1994,1995,1997,1998,1999,2000 Massachusetts Institute of Technology
+Copyright 2001,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(close-port port)
(set! port #f)
unspecific))))))))))
-\f
-(define (initialize-system-primitives!)
- (discard-select-registry-result-vectors!)
- (add-event-receiver! event:after-restart
- discard-select-registry-result-vectors!))
-
-(define os2/select-registry-lub)
-(define select-registry-result-vectors)
-
-(define (discard-select-registry-result-vectors!)
- (set! os2/select-registry-lub ((ucode-primitive os2-select-registry-lub 0)))
- (set! select-registry-result-vectors '())
- unspecific)
-(define (allocate-select-registry-result-vector)
- (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
- (let ((v
- (let loop ((rv select-registry-result-vectors))
- (if (pair? rv)
- (let ((v (car rv)))
- (if v
- (begin
- (set-car! rv #f)
- v)
- (loop (cdr rv))))
- (make-string os2/select-registry-lub)))))
- (set-interrupt-enables! interrupt-mask)
- v)))
-
-(define (deallocate-select-registry-result-vector v)
- (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
- (let loop ((rv select-registry-result-vectors))
- (if (pair? rv)
- (if (car rv)
- (loop (cdr rv))
- (set-car! rv v))
- (set! select-registry-result-vectors
- (cons v select-registry-result-vectors))))
- (set-interrupt-enables! interrupt-mask))
+(define (initialize-system-primitives!)
unspecific)
\f
-(define (make-select-registry . descriptors)
- (let ((registry (make-string os2/select-registry-lub)))
- (vector-8b-fill! registry 0 os2/select-registry-lub 0)
- (do ((descriptors descriptors (cdr descriptors)))
- ((not (pair? descriptors)))
- (add-to-select-registry! registry (car descriptors)))
- registry))
-
-(define (os2/guarantee-select-descriptor descriptor procedure)
- (if (not (and (fix:fixnum? descriptor)
- (fix:<= 0 descriptor)
- (fix:< descriptor os2/select-registry-lub)))
- (error:wrong-type-argument descriptor "select descriptor" procedure))
- descriptor)
-
-(define (add-to-select-registry! registry descriptor)
- (os2/guarantee-select-descriptor descriptor 'ADD-TO-SELECT-REGISTRY!)
- (vector-8b-set! registry descriptor 1))
-
-(define (remove-from-select-registry! registry descriptor)
- (os2/guarantee-select-descriptor descriptor 'REMOVE-FROM-SELECT-REGISTRY!)
- (vector-8b-set! registry descriptor 0))
-
-(define (select-descriptor descriptor block?)
- (vector-ref os2/select-result-values
- ((ucode-primitive os2-select-descriptor 2) descriptor block?)))
-
-(define (select-registry-test registry block?)
- (let ((result-vector (allocate-select-registry-result-vector)))
- (let ((result
- ((ucode-primitive os2-select-registry-test 3) registry
- result-vector
- block?)))
- (if (fix:= result 0)
- (let loop
- ((index (fix:- os2/select-registry-lub 1))
- (descriptors '()))
- (let ((descriptors
- (if (fix:= 0 (vector-8b-ref result-vector index))
- descriptors
- (cons index descriptors))))
- (if (fix:= 0 index)
- (begin
- (deallocate-select-registry-result-vector result-vector)
- descriptors)
- (loop (fix:- index 1) descriptors))))
- (begin
- (deallocate-select-registry-result-vector result-vector)
- (vector-ref os2/select-result-values result))))))
-
-(define os2/select-result-values
- '#(INPUT-AVAILABLE #F INTERRUPT PROCESS-STATUS-CHANGE))
-\f
;;;; Subprocess/Shell Support
(define (os/make-subprocess filename arguments environment working-directory
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.422 2003/01/09 19:36:50 cph Exp $
+$Id: runtime.pkg,v 14.423 2003/01/22 02:05:28 cph Exp $
Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology
Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology
(define-package (runtime os-primitives)
(parent (runtime))
(export ()
- add-to-select-registry!
copy-file
current-home-directory
current-user-name
file-time->universal-time
get-environment-variable
init-file-specifier->pathname
- make-select-registry
os/default-end-of-line-translation
os/exec-path
os/executable-pathname-types
os/make-subprocess
os/parse-path-string
os/shell-file-name
- remove-from-select-registry!
- select-descriptor
- select-registry-test
set-file-modes!
set-file-times!
temporary-directory-pathname
terminal-raw-input
terminal-raw-output
terminal-set-state
- test-for-input-on-channel
- test-for-input-on-descriptor
+ test-for-io-on-channel
+ test-for-io-on-descriptor
tty-input-channel
tty-output-channel
with-channel-blocking)
(export (runtime x-graphics)
have-select?)
(export (runtime thread)
- have-select?)
+ add-to-select-registry!
+ have-select?
+ make-select-registry
+ remove-from-select-registry!
+ test-select-registry)
(export (runtime directory)
directory-channel/descriptor)
(initialization (initialize-package!)))
create-thread-continuation
current-thread
deregister-all-events
- deregister-input-descriptor-events
- deregister-input-thread-event
+ deregister-io-descriptor-events
+ deregister-io-thread-event
deregister-timer-event
detach-thread
exit-current-thread
lock-thread-mutex
make-thread-mutex
other-running-threads?
- permanently-register-input-thread-event
- register-input-thread-event
+ permanently-register-io-thread-event
+ register-io-thread-event
register-timer-event
restart-thread
set-thread-timer-interval!
(export (runtime interrupt-handler)
thread-timer-interrupt-handler)
(export (runtime primitive-io)
- block-on-input-descriptor)
+ block-on-io-descriptor)
(export (runtime continuation)
get-thread-event-block
set-thread-event-block!)
#| -*-Scheme-*-
-$Id: socket.scm,v 1.19 2002/11/20 19:46:23 cph Exp $
+$Id: socket.scm,v 1.20 2003/01/22 02:05:34 cph Exp $
-Copyright (c) 1990-2002 Massachusetts Institute of Technology
+Copyright 1996,1997,1998,1999,2001,2002 Massachusetts Institute of Technology
+Copyright 2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(lambda ()
(let ((do-test
(lambda (k)
- (let ((result (test-for-input-on-channel server-socket)))
+ (let ((result
+ (test-for-io-on-channel server-socket 'READ)))
(case result
- ((INPUT-AVAILABLE)
+ ((READ)
(open-channel
(lambda (p)
(with-thread-timer-stopped
#| -*-Scheme-*-
-$Id: thread.scm,v 1.36 2002/11/20 19:46:23 cph Exp $
+$Id: thread.scm,v 1.37 2003/01/22 02:05:41 cph Exp $
-Copyright (c) 1991-1999 Massachusetts Institute of Technology
+Copyright 1991,1992,1993,1998,1999,2001 Massachusetts Institute of Technology
+Copyright 2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(set! thread-timer-running? #f)
(set! timer-records #f)
(set! timer-interval 100)
- (initialize-input-blocking)
- (add-event-receiver! event:after-restore initialize-input-blocking)
+ (initialize-io-blocking)
+ (add-event-receiver! event:after-restore initialize-io-blocking)
(detach-thread (make-thread #f))
(add-event-receiver! event:before-exit stop-thread-timer))
(map-over-population thread-population (lambda (thread) thread)))
(define (thread-execution-state thread)
- (guarantee-thread thread thread-execution-state)
+ (guarantee-thread thread 'THREAD-EXECUTION-STATE)
(thread/execution-state thread))
(define (create-thread root-continuation thunk)
(thread/next (current-thread)))
(define (thread-continuation thread)
- (guarantee-thread thread thread-continuation)
+ (guarantee-thread thread 'THREAD-CONTINUATION)
(without-interrupts
(lambda ()
(and (eq? 'WAITING (thread/execution-state thread))
(begin
(set! last-running-thread #f)
(%maybe-toggle-thread-timer)
- (wait-for-input))))
+ (wait-for-io))))
\f
(define (run-thread thread)
(let ((continuation (thread/continuation thread)))
(lambda (thread)
(let ((block-events? (thread/block-events? thread)))
(set-thread/block-events?! thread #f)
- (maybe-signal-input-thread-events)
+ (maybe-signal-io-thread-events)
(let ((any-events? (handle-thread-events thread)))
(set-thread/block-events?! thread block-events?)
(if (not any-events?)
(thread-not-running thread 'STOPPED))))))))
(define (restart-thread thread discard-events? event)
- (guarantee-thread thread restart-thread)
+ (guarantee-thread thread 'RESTART-THREAD)
(let ((discard-events?
(if (eq? discard-events? 'ASK)
(prompt-for-confirmation
(define (thread-timer-interrupt-handler)
(set-interrupt-enables! interrupt-mask/gc-ok)
(deliver-timer-events)
- (maybe-signal-input-thread-events)
+ (maybe-signal-io-thread-events)
(let ((thread first-running-thread))
(cond ((not thread)
(%maybe-toggle-thread-timer))
(set-thread/block-events?! thread #t)
(ring/discard-all (thread/pending-events thread))
(translate-to-state-point (thread/root-state-point thread))
- (%deregister-input-thread-events thread #t)
+ (%deregister-io-thread-events thread #t)
(%discard-thread-timer-records thread)
(%disassociate-joined-threads thread)
(%disassociate-thread-mutexes thread)
(thread-not-running thread 'DEAD)))
(define (join-thread thread event-constructor)
- (guarantee-thread thread join-thread)
+ (guarantee-thread thread 'JOIN-THREAD)
(let ((self (current-thread)))
(if (eq? thread self)
(signal-thread-deadlock self "join thread" join-thread thread)
(event-constructor thread value))))))))))
(define (detach-thread thread)
- (guarantee-thread thread detach-thread)
+ (guarantee-thread thread 'DETACH-THREAD)
(without-interrupts
(lambda ()
(if (eq? (thread/exit-value thread) detached-thread-marker)
(define (release-joined-threads thread value)
(set-thread/exit-value! thread value)
(do ((joined (thread/joined-threads thread) (cdr joined)))
- ((null? joined))
+ ((not (pair? joined)))
(let ((joined (caar joined))
(event ((cdar joined) thread value)))
(set-thread/joined-to! joined (delq! thread (thread/joined-to joined)))
(define (%disassociate-joined-threads thread)
(do ((threads (thread/joined-to thread) (cdr threads)))
- ((null? threads))
+ ((not (pair? threads)))
(set-thread/joined-threads!
(car threads)
(del-assq! thread (thread/joined-threads (car threads)))))
(set-thread/joined-to! thread '()))
\f
-;;;; Input Thread Events
+;;;; I/O Thread Events
-(define input-registry)
-(define input-registrations)
+(define io-registry)
+(define io-registrations)
(define-structure (dentry (conc-name dentry/))
(descriptor #f read-only #t)
+ (mode #f read-only #t)
first-tentry
last-tentry
prev
prev
next)
-(define (initialize-input-blocking)
- (set! input-registry (and have-select? (make-select-registry)))
- (set! input-registrations #f)
+(define (initialize-io-blocking)
+ (set! io-registry (and have-select? (make-select-registry)))
+ (set! io-registrations #f)
unspecific)
-(define-integrable (maybe-signal-input-thread-events)
- (if input-registrations
- (signal-select-result (select-registry-test input-registry #f))))
+(define (maybe-signal-io-thread-events)
+ (if io-registrations
+ (signal-select-result (test-select-registry io-registry #f))))
-(define (wait-for-input)
+(define (wait-for-io)
(let ((catch-errors
(lambda (thunk)
(let ((thread (console-thread)))
condition
(within-continuation k thunk))
thunk))))))))
- (if (not input-registrations)
+ (if (not io-registrations)
(begin
;; Busy-waiting here is a bad idea -- should implement a
;; primitive to block the Scheme process while waiting for a
(catch-errors
(lambda ()
(set-interrupt-enables! interrupt-mask/all)
- (select-registry-test input-registry #t)))))
+ (test-select-registry io-registry #t)))))
(set-interrupt-enables! interrupt-mask/gc-ok)
(signal-select-result result)
(let ((thread first-running-thread))
(if thread
(if (thread/continuation thread)
(run-thread thread))
- (wait-for-input)))))))
+ (wait-for-io)))))))
(define (signal-select-result result)
(cond ((pair? result)
- (signal-input-thread-events result))
+ (signal-io-thread-events (car result) (cdr result)))
((eq? 'PROCESS-STATUS-CHANGE result)
- (signal-input-thread-events '(PROCESS-STATUS-CHANGE)))))
+ (signal-io-thread-events '#(1 PROCESS-STATUS-CHANGE) '#(0)))))
\f
-(define (block-on-input-descriptor descriptor)
+(define (block-on-io-descriptor descriptor mode)
(without-interrupts
(lambda ()
(let ((result 'INTERRUPT)
(lambda ()
(let ((thread (current-thread)))
(set! registration-1
- (%register-input-thread-event
+ (%register-io-thread-event
descriptor
+ mode
thread
- (lambda ()
- (set! result 'INPUT-AVAILABLE)
+ (lambda (mode)
+ (set! result mode)
unspecific)
#f #t))
(set! registration-2
- (%register-input-thread-event
+ (%register-io-thread-event
'PROCESS-STATUS-CHANGE
+ 'READ
thread
- (lambda ()
+ (lambda (mode)
+ mode
(set! result 'PROCESS-STATUS-CHANGE)
unspecific)
#f #t)))
(%suspend-current-thread)
result)
(lambda ()
- (%deregister-input-thread-event registration-1)
- (%deregister-input-thread-event registration-2)))))))
+ (%deregister-io-thread-event registration-2)
+ (%deregister-io-thread-event registration-1)))))))
-(define (permanently-register-input-thread-event descriptor thread event)
- (guarantee-thread thread permanently-register-input-thread-event)
+(define (permanently-register-io-thread-event descriptor mode thread event)
+ (guarantee-thread thread 'PERMANENTLY-REGISTER-IO-THREAD-EVENT)
(without-interrupts
(lambda ()
- (%register-input-thread-event descriptor thread event #t #f))))
+ (%register-io-thread-event descriptor mode thread event #t #f))))
-(define (register-input-thread-event descriptor thread event)
- (guarantee-thread thread register-input-thread-event)
+(define (register-io-thread-event descriptor mode thread event)
+ (guarantee-thread thread 'REGISTER-IO-THREAD-EVENT)
(without-interrupts
(lambda ()
- (%register-input-thread-event descriptor thread event #f #f))))
+ (%register-io-thread-event descriptor mode thread event #f #f))))
-(define (deregister-input-thread-event tentry)
+(define (deregister-io-thread-event tentry)
(if (not (tentry? tentry))
- (error:wrong-type-argument tentry "input thread event registration"
- 'DEREGISTER-INPUT-THREAD-EVENT))
+ (error:wrong-type-argument tentry "I/O thread event registration"
+ 'DEREGISTER-IO-THREAD-EVENT))
(without-interrupts
(lambda ()
- (%deregister-input-thread-event tentry)
+ (%deregister-io-thread-event tentry)
(%maybe-toggle-thread-timer))))
-(define (deregister-input-descriptor-events descriptor)
+(define (deregister-io-descriptor-events descriptor mode)
(without-interrupts
(lambda ()
- (let loop ((dentry input-registrations))
- (if dentry
- (if (eqv? descriptor (dentry/descriptor dentry))
- (begin
- (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
- (remove-from-select-registry! input-registry descriptor))
- (let ((prev (dentry/prev dentry))
- (next (dentry/next dentry)))
- (if prev
- (set-dentry/next! prev next)
- (set! input-registrations next))
- (if next
- (set-dentry/prev! next prev))))
- (loop (dentry/next dentry))))))))
+ (let loop ((dentry io-registrations))
+ (cond ((not dentry)
+ unspecific)
+ ((and (eqv? descriptor (dentry/descriptor dentry))
+ (eq? mode (dentry/mode dentry)))
+ (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
+ (remove-from-select-registry! io-registry descriptor mode))
+ (let ((prev (dentry/prev dentry))
+ (next (dentry/next dentry)))
+ (if prev
+ (set-dentry/next! prev next)
+ (set! io-registrations next))
+ (if next
+ (set-dentry/prev! next prev))))
+ (else
+ (loop (dentry/next dentry))))))))
\f
-(define (%register-input-thread-event descriptor thread event
- permanent? front?)
- (let ((tentry (make-tentry thread event permanent?))
- (dentry
- (let loop ((dentry input-registrations))
- (and dentry
- (if (eqv? descriptor (dentry/descriptor dentry))
- dentry
- (loop (dentry/next dentry)))))))
- (if (not dentry)
- (let ((dentry (make-dentry descriptor #f #f #f #f)))
- (set-tentry/dentry! tentry dentry)
- (set-tentry/prev! tentry #f)
- (set-tentry/next! tentry #f)
- (set-dentry/first-tentry! dentry tentry)
- (set-dentry/last-tentry! dentry tentry)
- (if input-registrations
- (set-dentry/prev! input-registrations dentry))
- (set-dentry/next! dentry input-registrations)
- (set! input-registrations dentry)
- (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
- (add-to-select-registry! input-registry descriptor)))
- (begin
- (set-tentry/dentry! tentry dentry)
- (if front?
- (let ((next (dentry/first-tentry dentry)))
- (set-tentry/prev! tentry #f)
- (set-tentry/next! tentry next)
- (set-dentry/first-tentry! dentry tentry)
- (set-tentry/prev! next tentry))
- (let ((prev (dentry/last-tentry dentry)))
- (set-tentry/prev! tentry prev)
- (set-tentry/next! tentry #f)
- (set-dentry/last-tentry! dentry tentry)
- (set-tentry/next! prev tentry)))))
+(define (%register-io-thread-event descriptor mode thread event permanent?
+ front?)
+ (let ((tentry (make-tentry thread event permanent?)))
+ (let loop ((dentry io-registrations))
+ (cond ((not dentry)
+ (let ((dentry
+ (make-dentry descriptor
+ mode
+ tentry
+ tentry
+ #f
+ io-registrations)))
+ (set-tentry/dentry! tentry dentry)
+ (set-tentry/prev! tentry #f)
+ (set-tentry/next! tentry #f)
+ (if io-registrations
+ (set-dentry/prev! io-registrations dentry))
+ (set! io-registrations dentry)
+ (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
+ (add-to-select-registry! io-registry descriptor mode))))
+ ((and (eqv? descriptor (dentry/descriptor dentry))
+ (eq? mode (dentry/mode dentry)))
+ (set-tentry/dentry! tentry dentry)
+ (if front?
+ (let ((next (dentry/first-tentry dentry)))
+ (set-tentry/prev! tentry #f)
+ (set-tentry/next! tentry next)
+ (set-dentry/first-tentry! dentry tentry)
+ (set-tentry/prev! next tentry))
+ (let ((prev (dentry/last-tentry dentry)))
+ (set-tentry/prev! tentry prev)
+ (set-tentry/next! tentry #f)
+ (set-dentry/last-tentry! dentry tentry)
+ (set-tentry/next! prev tentry))))
+ (else
+ (loop (dentry/next dentry)))))
(%maybe-toggle-thread-timer)
tentry))
-(define (%deregister-input-thread-event tentry)
+(define (%deregister-io-thread-event tentry)
(if (tentry/dentry tentry)
(delete-tentry! tentry)))
-(define (%deregister-input-thread-events thread permanent?)
- (let loop ((dentry input-registrations) (tentries '()))
+(define (%deregister-io-thread-events thread permanent?)
+ (let loop ((dentry io-registrations) (tentries '()))
(if (not dentry)
(do ((tentries tentries (cdr tentries)))
- ((null? tentries))
+ ((not (pair? tentries)))
(delete-tentry! (car tentries)))
(loop (dentry/next dentry)
(let loop
(cons tentry tentries)
tentries))))))))
\f
-(define (signal-input-thread-events descriptors)
- (let loop ((dentry input-registrations) (events '()))
- (cond ((not dentry)
- (do ((events events (cdr events)))
- ((null? events))
- (%signal-thread-event (caar events) (cdar events)))
- (%maybe-toggle-thread-timer))
- ((let ((descriptor (dentry/descriptor dentry)))
- (let loop ((descriptors descriptors))
- (and (not (null? descriptors))
- (or (eqv? descriptor (car descriptors))
- (loop (cdr descriptors))))))
- (let ((next (dentry/next dentry))
- (tentry (dentry/first-tentry dentry)))
- (let ((events
- (cons (cons (tentry/thread tentry)
- (tentry/event tentry))
- events)))
- (if (tentry/permanent? tentry)
- (move-tentry-to-back! tentry)
- (delete-tentry! tentry))
- (loop next events))))
- (else
- (loop (dentry/next dentry) events)))))
+(define (signal-io-thread-events vr vw)
+ (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)))
+ (do ((events events (cdr events)))
+ ((not (pair? events)))
+ (%signal-thread-event (caar events) (cdar events)))))))
(define (move-tentry-to-back! tentry)
(let ((next (tentry/next tentry)))
(begin
(let ((descriptor (dentry/descriptor dentry)))
(if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
- (remove-from-select-registry! input-registry descriptor)))
+ (remove-from-select-registry! io-registry
+ descriptor
+ (dentry/mode dentry))))
(let ((prev (dentry/prev dentry))
(next (dentry/next dentry)))
(if prev
(set-dentry/next! prev next)
- (set! input-registrations next))
+ (set! io-registrations next))
(if next
- (set-dentry/prev! next prev))))))
- unspecific)
+ (set-dentry/prev! next prev)))))))
\f
;;;; Events
unspecific)))
\f
(define (signal-thread-event thread event)
- (guarantee-thread thread signal-thread-event)
+ (guarantee-thread thread 'SIGNAL-THREAD-EVENT)
(let ((self first-running-thread))
(if (eq? thread self)
(let ((block-events? (block-thread-events)))
(let ((block-events? (thread/block-events? thread)))
(set-thread/block-events?! thread #f)
(deliver-timer-events)
- (maybe-signal-input-thread-events)
+ (maybe-signal-io-thread-events)
(handle-thread-events thread)
(set-thread/block-events?! thread block-events?))
(begin
(deliver-timer-events)
- (maybe-signal-input-thread-events)))))))
+ (maybe-signal-io-thread-events)))))))
\f
;;;; Timer Events
(let ((block-events? (thread/block-events? thread)))
(set-thread/block-events?! thread #t)
(ring/discard-all (thread/pending-events thread))
- (%deregister-input-thread-events thread #f)
+ (%deregister-io-thread-events thread #f)
(%discard-thread-timer-records thread)
(set-thread/block-events?! thread block-events?))
(set-interrupt-enables! interrupt-mask/all)))
(define (%maybe-toggle-thread-timer)
(cond ((and timer-interval
- (or input-registrations
+ (or io-registrations
(let ((current-thread first-running-thread))
(and current-thread
(thread/next current-thread)))))
(error:wrong-type-argument mutex "thread-mutex" procedure)))
(define (thread-mutex-owner mutex)
- (guarantee-thread-mutex mutex thread-mutex-owner)
+ (guarantee-thread-mutex mutex 'THREAD-MUTEX-OWNER)
(thread-mutex/owner mutex))
(define (lock-thread-mutex mutex)
- (guarantee-thread-mutex mutex lock-thread-mutex)
+ (guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX)
(without-interrupts
(lambda ()
(let ((thread (current-thread))
(set-thread-mutex/owner! mutex thread)))
(define (unlock-thread-mutex mutex)
- (guarantee-thread-mutex mutex unlock-thread-mutex)
+ (guarantee-thread-mutex mutex 'UNLOCK-THREAD-MUTEX)
(without-interrupts
(lambda ()
(let ((owner (thread-mutex/owner mutex)))
thread))
\f
(define (try-lock-thread-mutex mutex)
- (guarantee-thread-mutex mutex try-lock-thread-mutex)
+ (guarantee-thread-mutex mutex 'TRY-LOCK-THREAD-MUTEX)
(without-interrupts
(lambda ()
(and (not (thread-mutex/owner mutex))
#t)))))
(define (with-thread-mutex-locked mutex thunk)
- (guarantee-thread-mutex mutex lock-thread-mutex)
+ (guarantee-thread-mutex mutex 'WITH-THREAD-MUTEX-LOCKED)
(let ((thread (current-thread))
(grabbed-lock?))
(dynamic-wind
(define (%disassociate-thread-mutexes thread)
(do ((mutexes (thread/mutexes thread) (cdr mutexes)))
- ((null? mutexes))
+ ((not (pair? mutexes)))
(let ((mutex (car mutexes)))
(if (eq? (thread-mutex/owner mutex) thread)
(%%unlock-thread-mutex mutex)
#| -*-Scheme-*-
-$Id: unxprm.scm,v 1.63 2002/11/20 19:46:24 cph Exp $
+$Id: unxprm.scm,v 1.64 2003/01/22 02:05:47 cph Exp $
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
+Copyright 1994,1995,1997,1998,1999,2000 Massachusetts Institute of Technology
+Copyright 2001,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(set-environment-variable! variable *variable-deleted*)))
(set! reset-environment-variables!
- (lambda () (set! environment-variables '())))
-) ; End LET
+ (lambda () (set! environment-variables '()))))
+
+(define (initialize-system-primitives!)
+ (add-event-receiver! event:after-restart reset-environment-variables!))
\f
(define (user-home-directory user-name)
(let ((directory ((ucode-primitive get-user-home-directory 1) user-name)))
specifier)))
(user-homedir-pathname)))
\f
-;;; Queues after-restart daemon to clean up environment space
-
-(define (initialize-system-primitives!)
- (add-event-receiver! event:after-restart reset-environment-variables!)
- (discard-select-registry-result-vectors!)
- (add-event-receiver! event:after-restart
- discard-select-registry-result-vectors!))
-
-(define (make-select-registry . descriptors)
- (let ((registry (make-string ((ucode-primitive select-registry-size 0)))))
- ((ucode-primitive select-registry-clear-all 1) registry)
- (do ((descriptors descriptors (cdr descriptors)))
- ((not (pair? descriptors)))
- ((ucode-primitive select-registry-set 2) registry (car descriptors)))
- registry))
-
-(define (add-to-select-registry! registry descriptor)
- ((ucode-primitive select-registry-set 2) registry descriptor))
-
-(define (remove-from-select-registry! registry descriptor)
- ((ucode-primitive select-registry-clear 2) registry descriptor))
-
-(define (select-descriptor descriptor block?)
- (let ((result ((ucode-primitive select-descriptor 2) descriptor block?)))
- (case result
- ((0)
- #f)
- ((1)
- 'INPUT-AVAILABLE)
- ((-1)
- (subprocess-global-status-tick)
- 'PROCESS-STATUS-CHANGE)
- ((-2)
- 'INTERRUPT)
- (else
- (error "Illegal result from CHANNEL-SELECT:" result)))))
-\f
-(define (select-registry-test registry block?)
- (let ((result-vector (allocate-select-registry-result-vector)))
- (let ((result
- ((ucode-primitive select-registry-test 3) registry block?
- result-vector)))
- (if (fix:> result 0)
- (let loop ((index (fix:- result 1)) (descriptors '()))
- (let ((descriptors
- (cons (vector-ref result-vector index) descriptors)))
- (if (fix:= 0 index)
- (begin
- (deallocate-select-registry-result-vector result-vector)
- descriptors)
- (loop (fix:- index 1) descriptors))))
- (begin
- (deallocate-select-registry-result-vector result-vector)
- (cond ((fix:= 0 result)
- #f)
- ((fix:= -1 result)
- (subprocess-global-status-tick)
- 'PROCESS-STATUS-CHANGE)
- ((fix:= -2 result)
- 'INTERRUPT)
- (else
- (error "Illegal result from SELECT-REGISTRY-TEST:"
- result))))))))
-
-(define select-registry-result-vectors)
-
-(define (discard-select-registry-result-vectors!)
- (set! select-registry-result-vectors '())
- unspecific)
-
-(define (allocate-select-registry-result-vector)
- (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
- (let ((v
- (let loop ((rv select-registry-result-vectors))
- (if (pair? rv)
- (let ((v (car rv)))
- (if v
- (begin
- (set-car! rv #f)
- v)
- (loop (cdr rv))))
- (make-vector ((ucode-primitive select-registry-lub 0)) #f)))))
- (set-interrupt-enables! interrupt-mask)
- v)))
-
-(define (deallocate-select-registry-result-vector v)
- (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
- (let loop ((rv select-registry-result-vectors))
- (if (pair? rv)
- (if (car rv)
- (loop (cdr rv))
- (set-car! rv v))
- (set! select-registry-result-vectors
- (cons v select-registry-result-vectors))))
- (set-interrupt-enables! interrupt-mask)))
-\f
;;;; Subprocess/Shell Support
(define (os/make-subprocess filename arguments environment working-directory
#| -*-Scheme-*-
-$Id: version.scm,v 14.210 2002/11/20 19:46:24 cph Exp $
+$Id: version.scm,v 14.211 2003/01/22 02:05:54 cph Exp $
-Copyright (c) 1988-2002 Massachusetts Institute of Technology
+Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
+Copyright 1995,1996,1997,1998,1999,2000 Massachusetts Institute of Technology
+Copyright 2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(add-subsystem-identification! "Release" '(7 7 2 "pre"))
(snarf-microcode-version!)
(add-event-receiver! event:after-restore snarf-microcode-version!)
- (add-subsystem-identification! "Runtime" '(15 2)))
+ (add-subsystem-identification! "Runtime" '(15 3)))
(define (snarf-microcode-version!)
(add-subsystem-identification! "Microcode"
#| -*-Scheme-*-
-$Id: x11graph.scm,v 1.53 2002/11/20 19:46:24 cph Exp $
+$Id: x11graph.scm,v 1.54 2003/01/22 02:06:00 cph Exp $
-Copyright (c) 1989-2002 Massachusetts Institute of Technology
+Copyright 1989,1990,1991,1992,1993,1995 Massachusetts Institute of Technology
+Copyright 1996,1997,1998,1999,2000,2001 Massachusetts Institute of Technology
+Copyright 2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(define (make-event-previewer display)
(let ((registration))
(set! registration
- (permanently-register-input-thread-event
+ (permanently-register-io-thread-event
(x-display-descriptor (x-display/xd display))
+ 'READ
(current-thread)
- (lambda ()
+ (lambda (mode)
+ mode
(call-with-current-continuation
(lambda (continuation)
(bind-condition-handler
;; on its display argument, that means the
;; display has been closed.
condition
- (deregister-input-thread-event registration)
+ (deregister-io-thread-event registration)
(continuation unspecific))
(lambda ()
(let ((event
(define (%read-and-process-event display)
(let ((event
- (and (eq? 'INPUT-AVAILABLE
- (test-for-input-on-descriptor
+ (and (eq? 'READ
+ (test-for-io-on-descriptor
(x-display-descriptor (x-display/xd display))
- #t))
+ #t
+ 'READ))
(x-display-process-events (x-display/xd display) 1))))
(if event
(process-event display event))))
(if (and code (not (scxl-destroyed? (weak-car wcdr))))
(begin
;; Reinstall interrupt handler, then run user code
- (register-input-thread-event
+ (register-io-thread-event
(XConnectionNumber (weak-car wcdr))
- uitk-thread (weak-cdr wcdr))
+ 'READ
+ uitk-thread
+ (lambda (mode)
+ mode
+ ((weak-cdr wcdr))))
(code))))))
(define (call-if-still-there weak)
;; WEAK is a weak-list:
(weak (weak-cons child-work-code (weak-cons display #F))))
(without-interrupts
(lambda ()
- (register-input-thread-event
- file uitk-thread (call-if-still-there weak))))))))
+ (register-io-thread-event
+ file
+ 'READ
+ uitk-thread
+ (lambda (mode)
+ mode
+ (call-if-still-there weak)))))))))
(define (destroy-registration registration)
- (deregister-input-thread-event registration)
+ (deregister-io-thread-event registration)
'OK)
(define (shut-down-event-server display-number)
- (deregister-input-descriptor-events (%XConnectionNumber display-number)))
+ (deregister-io-descriptor-events (%XConnectionNumber display-number) 'READ))
\f
;;;Delayed events
projects / mit-scheme.git / commitdiff