[Scsh-checkins] CVS: scsh-0.6/scheme/rts events.scm,NONE,1.1

[Martin Gasbichler <mainzelm@users.sourceforge.net>]

Update of /cvsroot/scsh/scsh-0.6/scheme/rts
In directory usw-pr-cvs1:/tmp/cvs-serv1058

Added Files:
        events.scm 
Log Message:
Changes for Cygwin.


--- NEW FILE ---
; Copyright (c) 1999-2001 by Martin Gasbichler. See file COPYING.

;;; Functional event system.
;;; System by Olin Shivers, implementation by Martin Gasbichler

(define-record-type event :event
  (really-make-event type next)
  event?
  (type event-type set-event-type!)
  (next next-event set-next-event!))

(define (make-event type)
  (really-make-event type #f))

(define empty-event (make-event #f))

(define *most-recent-event* empty-event)

(define (most-recent-event) *most-recent-event*)

(define event-thread-queue #f)

;Wait for an event of a certain type.
(define (rts-wait-interrupt set pre-event type-in-set?)
  (with-interrupts-inhibited
   (lambda ()
     (let lp ((event (next-event pre-event)))
       (if event
           (if (type-in-set? (event-type event) set)
               event
               (lp (next-event event)))
           (begin (enqueue-thread! event-thread-queue (current-thread))
                  (block)
                  (lp (next-event pre-event))))))))

; same as above, but don't block 
(define (rts-maybe-wait-interrupt set pre-event type-in-set?)
  (let ((event (next-event pre-event)))
    (if event
        (if (type-in-set? (event-type event) set)
            event
            (rts-maybe-wait-interrupt set (next-event event) type-in-set?))
        #f)))


;Called when the interrupt actually happened.
;;; TODO w-i-i is problaly not necessary since they're off already
(define (register-interrupt type)
  (let ((waiters (with-interrupts-inhibited
                  (lambda ()
                    (set-next-event! *most-recent-event* (make-event type))
                    (set! *most-recent-event* (next-event *most-recent-event*))
                    (do ((waiters '() (cons (dequeue-thread! event-thread-queue)
                                            waiters)))
                        ((thread-queue-empty? event-thread-queue)
                         waiters))))))
    (for-each make-ready waiters)))

;;; has to be called with interrupts disabled
(define (waiting-for-os-event?)
  (not (thread-queue-empty? event-thread-queue)))
  
(define (initialize-events!)
  (set! event-thread-queue (make-thread-queue))
  (set-interrupt-handler! (enum interrupt os-signal) 
                          (lambda (type arg enabled-interrupts)
                            ; type is already set in the unix signal handler
                            (register-interrupt type)))
  (set-interrupt-handler! (enum interrupt keyboard) 
                          (lambda (enabled-interrupts)
                            (register-interrupt (enum interrupt keyboard))))
;  (call-after-gc! (lambda () (register-interrupt (enum interrupt post-gc))))
)
;;; the vm uses the timer for the scheduler
(define (schedule-timer-interrupt! msec)
  (spawn (lambda ()
           (sleep msec)
           (register-interrupt (enum interrupt alarm)))))