scsh-0.6/scsh/event.scm

78 lines
2.1 KiB
Scheme

;;; Functional event system.
;;; System by Olin Shivers, implementation by David Fisher
(define-record event
type
(next (make-placeholder))
((disclose e) (list "event" (event:type e))))
;Not exported!
(define *most-recent-event* (make-event interrupt/cont))
(define event-lock (make-lock))
(define (most-recent-event) *most-recent-event*)
(define (next-event event) (placeholder-value (event:next event)))
(define (event-type event) (event:type event))
;Called when the interrupt actually happened.
(define (register-interrupt type)
(obtain-lock event-lock)
(let ((new-event (make-event type)))
(placeholder-set! (event:next *most-recent-event*) new-event)
(set! *most-recent-event* new-event))
(release-lock event-lock))
;Wait for an event of a certain type.
(define (wait-interrupt type pre-event)
(let ((event (next-event pre-event)))
(if (eq? (event-type event) type)
event
(wait-interrupt type event))))
;Initialize the system.
(define (install-event-handlers!)
(let loop ((count 0))
(if (< count interrupt-count)
(let ((old-handler (vector-ref (interrupt-handlers-vector) count)))
(set-interrupt-handler
count
(lambda stuff
(register-interrupt count)
(apply old-handler stuff)))
(loop (+ count 1))))))
;;; extensions by JMG
(define (wait-interrupt-set set pre-event)
(let ((event (next-event pre-event)))
(if (memq (event-type event) set)
event
(wait-interrupt set event))))
; would need placeholder-queue exported..
(define (placeholder-value-set? placeholder)
(not (placeholder-queue placeholder)))
(define (most-recent-event? event)
(eq? event most-recent-event))
(define (nonblockwait-interrupt type event )
(general-nonblockwait-interrupt type event eq?))
(define (nonblockwait-interrupt-set set event )
(general-nonblockwait-interrupt set event memq))
(define (general-nonblockwait-interrupt waiting-for event compare)
(if (most-recent-event? event)
#f
(let ((event (next-event pre-event)))
(if (compare (event-type event) waiting-for)
event
(nonblockwait-interrupt type event)))))