home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / process < prev    next >
Text File  |  1994-05-23  |  2KB  |  69 lines
  1. ;;;; "process.scm",  Multi-Processing for Scheme
  2. ;;; Copyright (C) 1992, 1993 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'full-continuation)
  21. (require 'queue)
  22.  
  23. (define (add-process! thunk1)
  24.   (cond ((procedure? thunk1)
  25.      (defer-ints)
  26.      (enqueue! process:queue thunk1)
  27.      (allow-ints))
  28.     (else (slib:error "add-process!: wrong type argument " thunk1))))
  29.  
  30. (define (process:schedule!)
  31.   (defer-ints)
  32.   (cond ((queue-empty? process:queue) (allow-ints)
  33.                       'still-running)
  34.     (else (call-with-current-continuation
  35.            (lambda (cont)
  36.          (enqueue! process:queue cont)
  37.          (let ((proc (dequeue! process:queue)))
  38.            (allow-ints)
  39.            (proc 'run))
  40.          (kill-process!))))))
  41.  
  42. (define (kill-process!)
  43.   (defer-ints)
  44.   (cond ((queue-empty? process:queue) (allow-ints)
  45.                       (slib:exit))
  46.     (else (let ((proc (dequeue! process:queue)))
  47.         (allow-ints)
  48.         (proc 'run))
  49.           (kill-process!))))
  50.  
  51. (define ints-disabled #f)
  52. (define alarm-deferred #f)
  53.  
  54. (define (defer-ints) (set! ints-disabled #t))
  55.  
  56. (define (allow-ints)
  57.   (set! ints-disabled #f)
  58.   (cond (alarm-deferred
  59.       (set! alarm-deferred #f)
  60.       (alarm-interrupt))))
  61.  
  62. ;;; Make THE process queue.
  63. (define process:queue (make-queue))
  64.  
  65. (define (alarm-interrupt)
  66.   (alarm 1)
  67.   (if ints-disabled (set! alarm-deferred #t)
  68.       (process:schedule!)))
  69.