Re: [Chicken-users] scheduler

[F. Wittenberger]

#!/usr/bin/csi -s
;; Hi All,

;; I'm afraid it happened again: the test case I sent out did *not*
;; exercise the EBADFD situation.

;; We need to do a little more.  There has to be asynchronous i/o.
;; Here an extended version.

;; This is a multi player scene.  Hence we
(  require-extension
;; 
   srfi-18
;; [and
   posix tcp
;; for i/o].
)

(let ((title "On The Sinking Ship"))
  (enable-warnings #f)
  ;; let['s]rec[call] some common sense
  (letrec ((chop-head (lambda () (exit 1)))
           (definately (lambda (write text)
                         (write text (current-error-port))))
           (for-ever (lambda (do . something)
                       (apply do something)
                       (for-ever do something)))
           (leave (lambda () (exit 0)))
           (one-hundred-times (lambda (write text)
                                (do ((count 0 (+ count 1)))
                                    ((eqv? count 100) #t)
                                  (write text)
                                  (write #\newline))))
           (plug #f)
           (pull (lambda (plug) (file-close plug)))
           (receiver (make-thread
                      (lambda ()
                        (receive
                         (i o) (tcp-connect "127.0.0.1" 3033)
                         (set! plug (port->fileno i))
                         (let loop ((r (read-line i)))
                           (display r) (newline)
                           (if (not (eof-object? r)) (loop (read-line i))))))
                      "receiver"))
           (sing (lambda (song via)
                   (do ((i 0 (+ 1 i)))
                       ((= i (vector-length song)))
                     (via (vector-ref song i))
                     (via #\newline)
                     (thread-sleep! 0.5))))
           (radio (lambda ()
                    (let ((q (tcp-listen 3033)))
                      (receive (i o) (tcp-accept q)
                               (lambda (sound) (display sound o))))))
           (take-punishment (lambda (sentence)
                              (and (one-hundred-times
                                    (lambda (this)
                                      (definately display this)
                                      (definately display #\newline))
                                    sentence)
                                   (chop-head)))))
    ;; now the play:
    (print "Open Stage")
    (let* ((old-song '#("We shall overco.ome"
                        "we shall overco.ome"
                        "we shall overcome"
                        "some dayayayay"))
           (union (make-thread
                   (lambda ()
                     (handle-exceptions
                      ups
                      (begin
                        (thread-sleep! 1)
                        (display "We are afraid, we can't help you anymore.
Thanks for paying your membership fee.
"
                                 (current-error-port))
                        (leave))
                      (for-ever sing old-song (radio))))
                   "union"))
           (boss (make-thread
                  (lambda ()
                    (thread-sleep! 1.5)
                    (pull plug)
                    (display "Shut up!\n")
                    (thread-sleep! 2)
                    (leave))
                  "boss"))
           (regie (make-mutex 'seat)))
      (mutex-lock! regie)
      (print "The unions enters the scene.")
      (thread-start! union)
      (print "Note: the boss's window is open!")
      (thread-start! boss)
      (print "Now let's watch what happens.")
      (thread-start! receiver)
      (mutex-lock! regie)
      (take-punishment "We better dealt with bad file descriptors."))))