From 384c28fab462fbed922350b64fce198bb406418d Mon Sep 17 00:00:00 2001
From: mainzelm <mainzelm>
Date: Mon, 9 Apr 2001 07:55:50 +0000
Subject: [PATCH] Hand out the port and not just port-data to the handler.

---
 scheme/rts/port.scm |  4 +--
 scsh/newports.scm   | 75 ++++++++++++++++++++++++++++++++++++++++++---
 2 files changed, 73 insertions(+), 6 deletions(-)

diff --git a/scheme/rts/port.scm b/scheme/rts/port.scm
index 3eb7c50..9d581a7 100644
--- a/scheme/rts/port.scm
+++ b/scheme/rts/port.scm
@@ -226,7 +226,7 @@
 (define (real-char-ready? port)
   (if (not (open-input-port? port))
       (call-error "invalid argument" char-ready? port)
-      ((port-handler-ready? (port-handler port)) (port-data port))))
+      ((port-handler-ready? (port-handler port)) port)))
 	 
 
 ;----------------
@@ -338,7 +338,7 @@
 	 (call-error "invalid argument" output-port-ready? port))
 	(else
 	 (let ((val ((port-handler-ready? (port-handler port)) 
-		     (port-data port))))
+		     port)))
 	   (release-port-lock port)
 	   val))))
 
diff --git a/scsh/newports.scm b/scsh/newports.scm
index de4f090..3af1538 100644
--- a/scsh/newports.scm
+++ b/scsh/newports.scm
@@ -49,8 +49,8 @@
 ;;; Support for channel-ready?
 ;;; This applies to input- and output-ports
 
-(define (fdport-channel-ready? fdport*)
-  (channel-ready? (fdport-data:channel fdport*)))
+(define (fdport-channel-ready? fdport)
+  (channel-ready? (fdport-data:channel (port-data fdport))))
 
 ;Arbitrary, for now.
 (define buffer-size 255)
@@ -177,6 +177,10 @@
 (define fdport-data port-data)
 ; That was easy.
 
+(define (guess-output-policy port)
+  (if (= 0 (port-limit port)) 
+      bufpol/none
+      bufpol/block))
 
 (define (set-port-buffering port policy . maybe-size) 
   (cond ((and (fdport? port) (open-input-port? port))
@@ -518,14 +522,17 @@
     (set-fdport-data:revealed fdport* new-revealed)
     (vector-set! fdports old-fd #f)
     (close-channel ch)
-    (set-fdport-data:channel
+    (set-fdport-data:channel 
      fdport*
-     ((if (input-port? port) make-input-fdchannel make-output-fdchannel) fd))
+     (make-fd-channel port fd))
     (vector-set! fdports fd old-vector-ref)
     (%set-cloexec fd (not new-revealed)))
   (release-port-lock port)
   #f)  ; JMG: It used to return #f on succes in 0.5.1, so we do the same
 
+(define (make-fd-channel port fd)
+  ((if (input-port? port) make-input-fdchannel make-output-fdchannel) fd))
+
 (define (close-fdes fd)
   (evict-ports fd)
   (%close-fdes fd))
@@ -674,3 +681,63 @@
       (let-fluid $current-output-port port thunk))))
 
 ;;; replace rts/channel-port.scm end
+
+
+
+(define (nselect rvec wvec evec timeout)
+  (let ((rlist (vector->list rvec))
+	(wlist (vector->list wvec)))
+    (let ((imm-r (filter char-ready? rlist))
+	  (imm-w (filter output-port-ready? wlist)))
+      (if (and (null? imm-r)
+	       (null? imm-w))
+	  (select-threaded rlist wlist timeout)
+	  (values (list->vector imm-r)
+		  (list->vector imm-w)
+		  '#())))))
+
+(define (timeout-thread result-lock timeout)
+  (lambda ()
+    ((structure-ref threads sleep) timeout)
+    (release-lock result-lock)))
+
+(define (select-threaded rlist wlist timeout)
+  (let ((result-lock (make-lock))
+	(ready-lock (make-lock))
+	(read-ready (cons 'cell '()))
+	(write-ready (cons 'cell '()))
+	(are-we-ready? #f))
+    (let* ((port-waiter
+	    (lambda (ready? ready-list)
+	      (lambda (port)
+		(lambda ()
+;		  ((structure-ref interrupts disable-interrupts!))
+;		  (if (ready? port)
+;		      ((structure-ref interrupts enable-interrupts!))
+;		      (wait-for-channel ; enables interrupts
+;		       (fdport-data:channel 
+;			(fdport-data port))))
+		  (let lp ()
+		    (if (ready? port)
+			(begin 
+			  (obtain-lock ready-lock)
+			  (set-cdr! ready-list (cons port (cdr ready-list)))
+			  (release-lock ready-lock)
+			  (release-lock result-lock))
+			(if (not are-we-ready?)
+			    (begin ((structure-ref threads sleep) 20)
+				   (lp)))))))))
+	   (read-waiter (port-waiter char-ready? read-ready))
+	   (write-waiter (port-waiter output-port-ready? write-ready)))
+      (obtain-lock result-lock)
+      (for-each spawn (map read-waiter rlist))
+      (for-each spawn (map write-waiter wlist))
+      (if timeout (spawn (timeout-thread result-lock timeout)))
+      (obtain-lock result-lock)
+      (set! are-we-ready? #t)
+;      (relinquish-timeslice) 
+      (values (cdr read-ready)
+	      (cdr write-ready)
+	      '#()))))
+	  
+    
\ No newline at end of file