79 lines
2.2 KiB
Scheme
79 lines
2.2 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!)
|
|
(set! *most-recent-event* (make-event interrupt/cont))
|
|
(let loop ((count 0))
|
|
(if (< count number-of-interrupts)
|
|
(begin
|
|
;we're not interested in the setter-function here:
|
|
(low-interrupt-register
|
|
count
|
|
(lambda (enabled-interrupts)
|
|
(register-interrupt count)))
|
|
(loop (+ count 1))))))
|
|
|
|
;;; extensions by JMG
|
|
|
|
;;; takes list of interrupt/xxx's
|
|
;;; blocks until one of the interrupts in the set occurs
|
|
(define (wait-interrupt-set set pre-event)
|
|
(let ((event (next-event pre-event)))
|
|
(if (memq (event-type event) set)
|
|
event
|
|
(wait-interrupt-set 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 pre-event compare?)
|
|
(if (most-recent-event? pre-event)
|
|
#f
|
|
(let ((event (next-event pre-event)))
|
|
(if (compare? (event-type event) waiting-for)
|
|
event
|
|
(general-nonblockwait-interrupt waiting-for event compare?)))))
|