home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / events.scm < prev    next >
Text File  |  2000-04-07  |  3KB  |  90 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: events.scm,v 14.5 2000/04/07 20:42:30 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Event Distribution
  23. ;;; package: (runtime event-distributor)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (set! add-event-receiver! (make-receiver-modifier 'ADD-RECEIVER))
  29.   (set! remove-event-receiver! (make-receiver-modifier 'REMOVE-RECEIVER))
  30.   unspecific)
  31.  
  32. (define-structure (event-distributor
  33.            (constructor make-event-distributor ())
  34.            (conc-name event-distributor/))
  35.   (events (make-queue))
  36.   (lock false)
  37.   (receivers '()))
  38.  
  39. (define (event-distributor/invoke! event-distributor . arguments)
  40.   (enqueue! (event-distributor/events event-distributor)
  41.         (cons 'INVOKE-RECEIVERS arguments))
  42.   (process-events! event-distributor))
  43.  
  44. (define (make-receiver-modifier keyword)
  45.   (lambda (event-distributor receiver)
  46.     (if (not (event-distributor? event-distributor))
  47.     (error "Not an event distributor" event-distributor))
  48.     (enqueue! (event-distributor/events event-distributor)
  49.           (cons keyword receiver))
  50.     (process-events! event-distributor)))
  51.  
  52. (define add-event-receiver!)
  53. (define remove-event-receiver!)
  54.  
  55. (define (process-events! event-distributor)
  56.   (let ((old-lock))
  57.     (dynamic-wind
  58.      (lambda ()
  59.        (let ((lock (event-distributor/lock event-distributor)))
  60.      (set-event-distributor/lock! event-distributor true)
  61.      (set! old-lock lock)
  62.      unspecific))
  63.      (lambda ()
  64.        (if (not old-lock)
  65.        (queue-map! (event-distributor/events event-distributor)
  66.          (lambda (event)
  67.            (case (car event)
  68.          ((INVOKE-RECEIVERS)
  69.           (do ((receivers
  70.             (event-distributor/receivers event-distributor)
  71.             (cdr receivers)))
  72.               ((null? receivers))
  73.             (apply (car receivers) (cdr event))))
  74.          ((ADD-RECEIVER)
  75.           (let ((receiver (cdr event))
  76.             (receivers
  77.              (event-distributor/receivers event-distributor)))
  78.             (if (not (memv receiver receivers))
  79.             (set-event-distributor/receivers!
  80.              event-distributor
  81.              (append! receivers (list receiver))))))
  82.          ((REMOVE-RECEIVER)
  83.           (set-event-distributor/receivers!
  84.            event-distributor
  85.            (delv! (cdr event)
  86.               (event-distributor/receivers event-distributor))))
  87.          (else
  88.           (error "Illegal event" event)))))))
  89.      (lambda ()
  90.        (set-event-distributor/lock! event-distributor old-lock)))))