Index: scheduler.scm
===================================================================
--- scheduler.scm	(Revision 11974)
+++ scheduler.scm	(Arbeitskopie)
@@ -46,6 +46,8 @@
 # define C_signal_interrupted_p     C_SCHEME_FALSE
 #endif
 
+# include <sys/stat.h>
+
 #ifdef _WIN32
 # if _MSC_VER > 1300
 # include <winsock2.h>
@@ -145,9 +147,8 @@
       ;; Unblock threads blocked by I/O:
       (if eintr
 	  (##sys#force-primordial)
-	  (begin
-	    (unless (null? ##sys#fd-list)
-	      (##sys#unblock-threads-for-i/o) ) ) )
+	  (unless (null? ##sys#fd-list)
+ 	   (##sys#unblock-threads-for-i/o) ) )
       ;; Fetch and activate next ready thread:
       (let loop2 ()
 	(let ([nt (##sys#remove-from-ready-queue)])
@@ -212,6 +213,16 @@
 
 (define ##sys#timeout-list '())
 
+(define (##sys#remove-from-timeout-list! t)
+  (set! ##sys#timeout-list
+	(let loop ((l ##sys#timeout-list))
+	  (if (null? l) 
+	      l
+	      (let ((h (##sys#slot l 0)))
+		(if (eq? (##sys#slot h 1) t)
+		    (##sys#slot l 1)
+		    (cons h (loop (##sys#slot l 1)))))))))
+
 (define (##sys#thread-block-for-timeout! t tm)
   (dbg t " blocks for " tm)
   ;; This should really use a balanced tree:
@@ -341,6 +352,30 @@
   (##sys#setislot t 13 #f)
   (##sys#setslot t 11 (cons fd i/o)) )
 
+(define-foreign-variable error-bad-file int "(errno == EBADF)")
+
+(define (##sys#handle-bad-fd! e)
+  (dbg "check bad" e)
+  (let ((bad ((foreign-lambda*
+	       bool ((integer fd))
+	       "struct stat buf;"
+	       "int i = ( (fstat(fd, &buf) == -1 && errno == EBADF) ? 1 : 0);"
+	       "return(i);")
+	      (car e))))
+    (if bad
+	(for-each
+	 (lambda (thread)
+	   (thread-signal!
+	    thread
+	    (##sys#make-structure
+	     'condition
+	     '(exn i/o) ;; better? '(exn i/o net)
+	     (list '(exn . message) "bad file descriptor"
+		   '(exn . arguments) (list (car e))
+		   '(exn . location) thread) )))
+	 (cdr e)))
+    bad))
+
 (define (##sys#unblock-threads-for-i/o)
   (dbg "fd-list: " ##sys#fd-list)
   (let* ([to? (pair? ##sys#timeout-list)]
@@ -353,8 +388,23 @@
 		   (fxmax 0 (- tmo1 now)) )
 		 0) ) ] )		; otherwise immediate timeout.
     (dbg n " fds ready")
-    (cond [(eq? -1 n) 
-	   (##sys#force-primordial)]
+    (cond [(eq? -1 n)
+	   (cond
+	    (error-bad-file
+	     (set! ##sys#fd-list
+		   (let loop ((l ##sys#fd-list))
+		     (cond
+		      ((null? l) l)
+		      ((##sys#handle-bad-fd! (car l))
+		       (##sys#fdset-clear (caar l))
+		       ;; This is supposed to be a rare case, catch
+		       ;; them one by one.
+		       ;; (loop (cdr l))
+		       (cdr l))
+		      (else (cons (car l) (loop (cdr l)))))))
+	     (##sys#fdset-restore)
+	     (##sys#unblock-threads-for-i/o))
+	    (else (##sys#force-primordial))) ]
 	  [(fx> n 0)
 	   (set! ##sys#fd-list
 	     (let loop ([n n] [lst ##sys#fd-list])
@@ -376,6 +426,7 @@
 				 (when (and (pair? p)
 					    (eq? fd (car p))
 					    (not (##sys#slot t 13) ) ) ; not unblocked by timeout
+				   (##sys#remove-from-timeout-list! t)
 				   (##sys#thread-basic-unblock! t) )
 				 (loop2 (cdr threads)) ) ) )
 			 (cons a (loop n (cdr lst))) ) ) ) ) ) ] )
@@ -408,12 +459,28 @@
 
 ;;; Get list of all threads that are ready or waiting for timeout or waiting for I/O:
 
-(define (##sys#all-threads)
-  (append ##sys#ready-queue-head
-          (apply append (map cdr ##sys#fd-list))
-          (map cdr ##sys#timeout-list)))
+(define (##sys#all-threads . cons+init)
+  (let ((cons (if (null? cons+init)
+		  (lambda (queue arg val init)
+		    (cons val init))
+		  (car cons+init)))
+	(init (if (and (pair? cons+init) (pair? (cdr cons+init)))
+		  (cadr cons+init) '())))
+    (let loop ((l ##sys#ready-queue-head) (i init))
+      (if (pair? l)
+	  (loop (cdr l) (cons 'ready #f (car l) i))
+	  (let loop ((l ##sys#fd-list) (i i))
+	    (if (pair? l)
+		(loop (cdr l)
+		      (let ((fd (caar l)))
+			(let loop ((l (cdar l)))
+			  (if (null? l) i
+			      (cons 'i/o fd (car l) (loop (cdr l)))))))
+		(let loop ((l ##sys#timeout-list) (i i))
+		  (if (pair? l)
+		      (loop (cdr l) (cons 'timeout (caar l) (cdar l) i))
+		      i))))))))
 
-
 ;;; Remove all waiting threads from the relevant queues with the exception of the current thread:
 
 (define (##sys#fetch-and-clear-threads)
@@ -438,14 +505,7 @@
 
 (define (##sys#thread-unblock! t)
   (when (eq? 'blocked (##sys#slot t 3))
-    (set! ##sys#timeout-list
-      (let loop ((l ##sys#timeout-list))
-	(if (null? l) 
-	    l
-	    (let ((h (##sys#slot l 0)))
-	      (if (eq? (##sys#slot h 1) t)
-		  (##sys#slot l 1)
-		  (cons h (loop (##sys#slot l 1))))))))
+    (##sys#remove-from-timeout-list! t)
     (set! ##sys#fd-list 
       (let loop ([fdl ##sys#fd-list])
 	(if (null? fdl)