;;; 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?)))))