From 9b4bb8a19d50478364e9d6e65e7e6840f9809b92 Mon Sep 17 00:00:00 2001
From: mainzelm <mainzelm>
Date: Fri, 23 Mar 2001 10:59:07 +0000
Subject: [PATCH] Adapted some of Richard's changes for char-ready? and
 output-port-ready?.

---
 c/fd-io.h                   |   2 +
 c/unix/fd-io.c              |  29 +++++++
 scheme/big/more-port.scm    |  54 ++++++++-----
 scheme/interfaces.scm       |  28 ++++---
 scheme/packages.scm         |   4 +-
 scheme/rts-packages.scm     |  10 +--
 scheme/rts/channel-port.scm |  38 +++++----
 scheme/rts/port.scm         | 151 +++++++++++++++++++++++++++++-------
 scheme/vm/arch.scm          |   1 +
 scheme/vm/interfaces.scm    |   1 +
 scheme/vm/prim-io.scm       |  12 +++
 scheme/vm/ps-channel.scm    |   7 ++
 scheme/vm/s48-channel.scm   |   6 ++
 scsh/newports.scm           |  83 ++++++++++----------
 14 files changed, 305 insertions(+), 121 deletions(-)

diff --git a/c/fd-io.h b/c/fd-io.h
index 19255c0..8efdd8c 100644
--- a/c/fd-io.h
+++ b/c/fd-io.h
@@ -7,6 +7,8 @@ extern int ps_open_fd(char *in_filename, bool is_input, long *status);
 
 extern int ps_close_fd(long fd_as_long);
 
+extern bool ps_check_fd(long fd_as_long, bool is_read, long *status);
+
 extern long ps_read_fd(long fd_as_long, char *buf_as_long, long max, bool waitp,
 		       bool *eofp, bool *pending, long *status);
 
diff --git a/c/unix/fd-io.c b/c/unix/fd-io.c
index ff8df92..5f3ba3d 100644
--- a/c/unix/fd-io.c
+++ b/c/unix/fd-io.c
@@ -82,6 +82,35 @@ ps_close_fd(long fd_as_long)
   }
 }
 
+bool ps_check_fd(long fd_as_long, bool is_read, long *status)
+{
+  int fd = (int)fd_as_long;
+  int ready;
+
+  struct timeval timeout;
+  fd_set fds;
+
+  FD_ZERO(&fds);
+  FD_SET(fd, &fds);
+  timerclear(&timeout);
+
+  *status = NO_ERRORS;
+
+  while(TRUE) {
+    ready = select(fd + 1,
+		   is_read ? &fds : NULL,
+		   is_read ? NULL : &fds,
+		   &fds,
+		   &timeout);
+    if (ready == 0)
+	return FALSE;
+    else if (ready == 1)
+	return TRUE;
+    else if (errno != EINTR) {
+	*status = errno;
+	return FALSE; } } 
+}
+
 long
 ps_read_fd(long fd_as_long, char *buffer, long max, bool waitp,
 	   bool *eofp, bool *pending, long *status)
diff --git a/scheme/big/more-port.scm b/scheme/big/more-port.scm
index 4288123..02a3de0 100644
--- a/scheme/big/more-port.scm
+++ b/scheme/big/more-port.scm
@@ -95,7 +95,7 @@
 ; Input ports that keep track of the current row and column.
 
 (define tracking-input-port-handler
-  (make-port-handler
+  (make-buffered-input-port-handler
    (lambda (location)
      (list 'tracking-port (port-location-sub-port location)))
    (lambda (location)  ; nothing to do
@@ -111,11 +111,14 @@
 	      (update-row-and-column-from-bytes! buffer start res location))
 	     (else
 	      (update-row-and-column-from-chars! buffer start res location)))
-       res))))
+       res))
+   (lambda (port)
+     (char-ready? (port-location-sub-port (port-data port))))))
 
 (define (make-tracking-input-port port)
   (if (input-port? port)
-      (let ((new-port (make-input-port tracking-input-port-handler
+      (let ((new-port 
+	     (make-buffered-input-port tracking-input-port-handler
 				       (make-port-location port)
 				       (make-code-vector default-buffer-size 0)
 				       0
@@ -129,7 +132,7 @@
 ; Output ports that keep track of the current row and column.
 
 (define tracking-output-port-handler
-  (make-port-handler
+  (make-buffered-output-port-handler
    (lambda (location)
      (list 'tracking-port (port-location-sub-port location)))
    ; flush the buffer when closing
@@ -148,7 +151,9 @@
 	   ((code-vector? buffer)
 	    (update-row-and-column-from-bytes! buffer start count location))
 	   (else
-	    (update-row-and-column-from-chars! buffer start count location))))))
+	    (update-row-and-column-from-chars! buffer start count location))))
+   (lambda (port)
+     (output-port-ready? (port-location-sub-port (port-data port))))))
 
 (define (make-tracking-output-port port)
   (if (output-port? port)
@@ -173,21 +178,22 @@
 ; All the work is done by the port code.
 
 (define string-input-port-handler
-  (make-port-handler
+  (make-buffered-input-port-handler
    (lambda (ignore)
      (list 'string-input-port))
    (lambda (ignore)
      (values))
    (lambda (ignore buffer start needed)
-     (eof-object))))
+     (eof-object))
+   (lambda (port) #f)))
 
 (define (make-string-input-port string)
   (let ((buffer (make-code-vector (string-length string) 0)))
     (copy-bytes! string 0 buffer 0 (string-length string))
-    (make-input-port string-input-port-handler
-		     #f                          ; no additional state needed
-		     buffer
-		     0
+    (make-buffered-input-port string-input-port-handler
+			      #f                 ; no additional state needed
+			      buffer
+			      0
 		     (string-length string))))   ; number of bytes available
 
 (define copy-bytes! (structure-ref primitives copy-bytes!))
@@ -219,7 +225,7 @@
     out))
 
 (define string-output-port-handler
-  (make-port-handler
+  (make-buffered-output-port-handler
    (lambda (port)
      '(string-output-port))
    (lambda (port)
@@ -229,7 +235,8 @@
        (set-cdr! (port-data port)
 		 (cons (cons (full-buffer port thing start count)
 			     count)
-		       (cdr (port-data port))))))))
+		       (cdr (port-data port))))))
+   (lambda (port) #f)))
 
 (define (full-buffer port thing start count)
   (cond ((eq? thing (port-buffer port))
@@ -241,11 +248,12 @@
 	   b))))
 
 (define (make-string-output-port)
-  (let ((port (make-output-port string-output-port-handler
-				(list #f)
-				(make-code-vector default-buffer-size 0)
-				0
-				default-buffer-size)))
+  (let ((port (make-buffered-output-port 
+	       string-output-port-handler
+	       (list #f)
+	       (make-code-vector default-buffer-size 0)
+	       0
+	       default-buffer-size)))
     (set-car! (port-data port) port)
     port))
 
@@ -264,7 +272,8 @@
    (lambda (proc)
      (values))
    (lambda (proc char)
-     (proc char))))
+     (proc char))
+   (lambda (port) #t)))
 
 (define (char-sink->output-port proc)
   (make-unbuffered-output-port char-sink-output-port-handler
@@ -314,7 +323,12 @@
 		  (eof-object))
 		 (else
 		  (buffer-set! buffer start next)
-		  1)))))))
+		  1)))))
+   (lambda (port)
+     (if (or (port-pending-eof? port)
+	     (source-data-buffer (port-data port)))
+	 #t
+	 ((source-data-ready? (port-data port)))))))
 
 (define (buffer-set! buffer index char)
   (if (string? buffer)
diff --git a/scheme/interfaces.scm b/scheme/interfaces.scm
index c3e7095..eea7305 100644
--- a/scheme/interfaces.scm
+++ b/scheme/interfaces.scm
@@ -161,7 +161,9 @@
 	  channel-id
 	  channel-status
 	  channel-os-index
-	
+	  
+	  channel-ready?
+	  
 	  open-channel
 	  close-channel
 	  channel-read
@@ -447,6 +449,10 @@
 	  $current-output-port
 	  $current-error-port
 	  $current-noise-port
+	  make-buffered-input-port-handler
+	  make-buffered-output-port-handler
+	  make-buffered-input-port
+	  make-buffered-output-port
 	  ;; end of additions. ;;
 	  char-ready?
 	  read-block write-block
@@ -462,6 +468,7 @@
 	  current-error-port
 	  current-noise-port
 	  force-output			;xport.scm
+	  output-port-ready?
 	  input-port?
 	  output-port?
 	  silently
@@ -612,18 +619,17 @@
 	  call-before-heap-overflow!
 	  (interrupt :syntax)))
 
-(define-interface events-interface
-  (export rts-wait-interrupt
-	  rts-maybe-wait-interrupt
-	  most-recent-event
-	  event?
-	  next-event
-	  event-type
+(define-interface sigevents-interface
+  (export rts-next-sigevent
+	  rts-next-sigevent/no-wait
+	  most-recent-sigevent
+	  sigevent?
+	  sigevent-type
 	  schedule-timer-interrupt!))
 
-(define-interface events-internal-interface
-  (export waiting-for-os-event?
-	  initialize-events!))
+(define-interface sigevents-internal-interface
+  (export waiting-for-sigevent?
+	  initialize-sigevents!))
 
 (define-interface writing-interface
   (export write
diff --git a/scheme/packages.scm b/scheme/packages.scm
index afb6678..abd01b6 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -291,8 +291,8 @@
 	    methods
 	    meta-methods
 	    interrupts
-	    events
-	    events-internal
+	    sigevents
+	    sigevents-internal
 	    low-level
 	    more-types
 	    number-i/o
diff --git a/scheme/rts-packages.scm b/scheme/rts-packages.scm
index faf8df6..6b88590 100644
--- a/scheme/rts-packages.scm
+++ b/scheme/rts-packages.scm
@@ -219,13 +219,13 @@
   (files (rts interrupt))
   (optimize auto-integrate)) ;mostly for threads package...
 
-(define-structures ((events events-interface)
-		    (events-internal events-internal-interface))
+(define-structures ((sigevents sigevents-interface)
+		    (sigevents-internal sigevents-internal-interface))
   (open scheme-level-1 define-record-types
 	threads threads-internal
 	interrupts
 	architecture)
-  (files (rts events))
+  (files (rts sigevents))
   (optimize auto-integrate))
 
 
@@ -273,7 +273,7 @@
 	interrupts              ;with-interrupts-inhibited
 	wind                    ;call-with-current-continuation
 	channel-i/o		;waiting-for-i/o?
-	events-internal)                 ;waiting-for-os-event?
+	sigevents-internal)                 ;waiting-for-os-sigevent?
   (access primitives)		;unspecific, wait
   (files (rts root-scheduler)))
 
@@ -321,7 +321,7 @@
 	fluids-internal	 ;initialize-dynamic-state!
 	exceptions	 ;initialize-exceptions!
 	interrupts	 ;initialize-interrupts!
-	events-internal  ;initialize-events!
+	sigevents-internal  ;initialize-sigevents!
 	records-internal ;initialize-records!
 	export-the-record-type	;just what it says
 	threads-internal ;start threads
diff --git a/scheme/rts/channel-port.scm b/scheme/rts/channel-port.scm
index a9b44f5..af70db1 100644
--- a/scheme/rts/channel-port.scm
+++ b/scheme/rts/channel-port.scm
@@ -13,8 +13,11 @@
 ;  2) wait for at least one character, but not after that (from READ-CHAR)
 ;  3) exactly NEEDED characters are required (from READ-BLOCK)
 
+(define (channel-port-ready? channel-cell)
+  (channel-ready? (channel-cell-ref channel-cell)))
+
 (define input-channel-handler
-  (make-port-handler
+  (make-buffered-input-port-handler
    (lambda (channel-cell)
      (list 'input-port (channel-cell-ref channel-cell)))
    (lambda (channel-cell)
@@ -22,8 +25,9 @@
         (channel-cell-ref channel-cell)))
    (lambda (channel-cell buffer start needed)
      (channel-read buffer start needed (channel-cell-ref channel-cell)))
+   channel-port-ready?
    (lambda (channel-cell owner)
-     (steal-channel! (channel-cell-ref) owner))))
+     (steal-channel! (channel-cell-ref channel-cell) owner))))
 
 (define (input-channel->port channel . maybe-buffer-size)
   (real-input-channel->port channel maybe-buffer-size close-input-channel))
@@ -39,14 +43,14 @@
 			 (car maybe-buffer-size))))
     (if (>= 0 buffer-size)
 	(call-error "invalid buffer size" input-channel->port channel buffer-size)
-	(make-input-port input-channel-handler
-			 (make-channel-cell channel closer)
-			 (make-code-vector buffer-size 0)
-			 0
-			 0))))
+	(make-buffered-input-port input-channel-handler
+				  (make-channel-cell channel closer)
+				  (make-code-vector buffer-size 0)
+				  0
+				  0))))
   
 (define output-channel-handler
-  (make-port-handler
+  (make-buffered-output-port-handler
    (lambda (channel-cell)
      (list 'output-port (channel-cell-ref channel-cell)))
    (lambda (channel-cell)
@@ -54,6 +58,7 @@
         (channel-cell-ref channel-cell)))
    (lambda (channel-cell buffer start count)
      (channel-write buffer start count (channel-cell-ref channel-cell)))
+   channel-port-ready?
    (lambda (channel-cell owner)
      (steal-channel! (channel-cell-ref channel-cell) owner))))
 
@@ -70,8 +75,10 @@
      (lambda (channel-cell char)
        (code-vector-set! buffer 0 (char->ascii char))
        (channel-write buffer 0 1 (channel-cell-ref channel-cell)))
-      (lambda (channel-cell owner)
-	(steal-channel! (channel-cell-ref channel-cell) owner)))))
+     (lambda (channel-cell)
+       (channel-ready? (channel-cell-ref channel-cell)))
+     (lambda (channel-cell owner)
+       (steal-channel! (channel-cell-ref channel-cell) owner)))))
 
 ; Dispatch on the buffer size to make the appropriate port.  A buffer
 ; size of zero creates an unbuffered port.  Buffered output ports get a
@@ -96,11 +103,12 @@
 	   (make-unbuffered-output-port (make-unbuffered-output-channel-handler)
 					(make-channel-cell channel closer)))
 	  (else
-	   (let ((port (make-output-port output-channel-handler
-					 (make-channel-cell channel closer)
-					 (make-code-vector buffer-size 0)
-					 0
-					 buffer-size)))
+	   (let ((port (make-buffered-output-port 
+			output-channel-handler
+			(make-channel-cell channel closer)
+			(make-code-vector buffer-size 0)
+			0
+			buffer-size)))
 	     (periodically-force-output! port)
 	     ((structure-ref primitives add-finalizer!) port
 							maybe-force-output)
diff --git a/scheme/rts/port.scm b/scheme/rts/port.scm
index 99d3c4d..3eb7c50 100644
--- a/scheme/rts/port.scm
+++ b/scheme/rts/port.scm
@@ -9,17 +9,19 @@
 ;;; Main difference is, that the ports have a steal-field 
 
 (define-record-type port-handler :port-handler
-  (really-make-port-handler discloser close buffer-proc steal)
+  (really-make-port-handler discloser close buffer-proc ready? steal)
   port-handler?
   (discloser   port-handler-discloser)
   (close       port-handler-close)
   (buffer-proc port-handler-buffer-proc)
+  (ready?      port-handler-ready?)
   (steal       port-handler-steal))
 
-(define (make-port-handler discloser close buffer-proc . maybe-steal)
+(define (make-port-handler discloser close buffer-proc ready? . maybe-steal)
   (if (pair? maybe-steal)
-      (really-make-port-handler discloser close buffer-proc (car maybe-steal))
-      (really-make-port-handler discloser close buffer-proc
+      (really-make-port-handler discloser close buffer-proc ready? 
+				(car maybe-steal))
+      (really-make-port-handler discloser close buffer-proc ready?
 				(lambda (port-data owner) #f))))
 
 (define (disclose-port port)
@@ -222,28 +224,10 @@
 ; no arguments.
 
 (define (real-char-ready? port)
-  (cond ((not (open-input-port? port))
-	 (call-error "invalid argument" char-ready? port))
-	((not (maybe-obtain-port-lock port))
-	 #f)
-	((not (open-port? port))  ; have to check again after the lock call
-	 (release-port-lock port)
-	 (call-error "invalid argument" char-ready? port))
-	((or (< (port-index port) (port-limit port))
-	     (port-pending-eof? port))
-	 (release-port-lock port)
-	 #t)
-	(else
-	 (let ((got (fill-port-buffer! port 'immediate)))
-	   (cond ((eof-object? got)
-		  (set-port-pending-eof?! port #t)
-		  (release-port-lock port)
-		  #t)
-		 (else
-		  (set-port-index! port 0)
-		  (set-port-limit! port got)
-		  (release-port-lock port)
-		  (> got 0)))))))
+  (if (not (open-input-port? port))
+      (call-error "invalid argument" char-ready? port)
+      ((port-handler-ready? (port-handler port)) (port-data port))))
+	 
 
 ;----------------
 ; Check the arguments and the state of the buffer.  Leave any actual work
@@ -342,6 +326,22 @@
 (define (write-string string port)
   (write-block string 0 (string-length string) port))
 
+; CHAR-READY? for output ports.
+
+(define (output-port-ready? port)
+  (cond ((not (open-output-port? port))
+	 (call-error "invalid argument" output-port-ready? port))
+	((not (maybe-obtain-port-lock port))
+	 #f)
+	((not (open-port? port))  ; have to check again after the lock call
+	 (release-port-lock port)
+	 (call-error "invalid argument" output-port-ready? port))
+	(else
+	 (let ((val ((port-handler-ready? (port-handler port)) 
+		     (port-data port))))
+	   (release-port-lock port)
+	   val))))
+
 ; Copy the bytes into the buffer if there is room, otherwise write out anything
 ; in the buffer and then write BUFFER.
 
@@ -506,6 +506,8 @@
      (unspecific))
    (lambda (channel buffer start need)
      (unspecific))
+   (lambda (port)                        ; ready?
+     #t)
    (lambda (ignore1 ignore2)
      #f)))
 
@@ -657,5 +659,100 @@
     ; if we took OWNER off a channel-wait queue we need to make it ready to run
     (if status (make-ready owner))))
 			       
+;;;;; We don't have unbuffered input ports for now. It's possible to
+;;;;; define them if the handler takes care of the char for peek-char,
+;;;;; but there is not much point in having them. A buffered port with
+;;;;; buffer size 1 provides the same functionality. See 0.54 for
+;;;;; unbuffered input ports
 
-			       
+
+;;;;; buffered ports
+;;;;; 
+;;;;; This is only a skeleton. With the switch to 0.54 everything will
+;;;;; change anyway, but for char-ready? we need some abstraction now
+;;;;; This code is stolen from 0.54's port-buffer.scm and shortened
+
+(define (make-buffered-input-port handler data buffer index limit)
+  (if (and (okay-buffer? buffer index limit)
+	   (port-handler? handler))
+      (make-port handler
+		 (bitwise-ior input-port-mask open-input-port-mask)
+		 (make-lock)
+		 #f             ; locked? 
+		 data
+		 buffer
+		 index
+		 limit
+		 #f)            ; pending-eof?
+      (call-error "invalid argument"
+		  make-buffered-input-port handler data buffer index limit)))
+
+(define (make-buffered-output-port handler data buffer index limit)
+  (if (and (okay-buffer? buffer index limit)
+	   (> limit 0)
+	   (port-handler? handler))
+      (make-port handler
+		 open-output-port-status
+		 (make-lock)
+		 #f             ; locked? 
+		 data
+		 buffer
+		 index
+		 limit
+		 #f)            ; pending-eof?
+      (call-error "invalid argument"
+		  make-buffered-output-port handler data buffer index limit)))
+
+(define (okay-buffer? buffer index limit)
+  (and (code-vector? buffer)
+       (let ((length (code-vector-length buffer)))
+	 (integer? limit)
+	 (integer? index)
+	 (exact? limit)
+	 (exact? index)
+	 (<= 0 limit length)
+	 (<= 0 index limit))))
+
+
+(define (make-buffered-input-port-handler discloser
+					  closer!
+					  read-block!
+					  ready?
+					  . maybe-steal!)
+  (apply make-port-handler discloser
+	                   closer!
+			   read-block!
+			   (make-char-ready? ready? #t)
+			   maybe-steal!))			
+
+;----------------
+; See if there is a character available.
+
+(define (make-char-ready? ready? read?)
+  (lambda (port)
+    (cond ((not ((if read?
+		     open-input-port?
+		     open-output-port?)
+		 port))
+	   (call-error "invalid argument" char-ready? port))
+	  ((or (< (port-index port)
+		  (port-limit port))
+	       (and read?
+		    (port-pending-eof? port)))
+	   #t)
+	  (else
+	   (ready? port)))))
+
+
+(define (make-buffered-output-port-handler discloser
+					   closer!
+					   buffer-emptier!
+					   ready?
+					   . maybe-steal!)
+  (apply make-port-handler discloser
+	                   closer!
+			   buffer-emptier!
+			   (make-char-ready? ready? #f)
+			   maybe-steal!))
+		     
+	   
\ No newline at end of file
diff --git a/scheme/vm/arch.scm b/scheme/vm/arch.scm
index d2f5fd1..a2fde31 100644
--- a/scheme/vm/arch.scm
+++ b/scheme/vm/arch.scm
@@ -183,6 +183,7 @@
   (close-channel 1)
   (channel-maybe-read 5)
   (channel-maybe-write 4)
+  (channel-ready? 1)
   (channel-abort 1)             ; stop channel operation
   (open-channels-list)		; return a list of the open channels
   
diff --git a/scheme/vm/interfaces.scm b/scheme/vm/interfaces.scm
index c4bdfa8..7f3af39 100644
--- a/scheme/vm/interfaces.scm
+++ b/scheme/vm/interfaces.scm
@@ -399,6 +399,7 @@
 	  output-channel->port
 	  close-input-channel
 	  close-output-channel
+	  channel-ready?
 	  channel-read-block
 	  channel-write-block
 	  channel-abort
diff --git a/scheme/vm/prim-io.scm b/scheme/vm/prim-io.scm
index d3c4c8b..32c9d19 100644
--- a/scheme/vm/prim-io.scm
+++ b/scheme/vm/prim-io.scm
@@ -84,6 +84,18 @@
 	      (goto no-result)))
 	(raise-exception wrong-type-argument 0 channel))))
 
+(define-consing-primitive channel-ready? (channel->)
+  (lambda (ignore) error-string-size)
+  (lambda (channel key)
+    (if (open? channel)
+	(receive (ready? status)
+	    (channel-ready? (extract-channel channel)
+			    (input-channel? channel))
+	  (if (error? status)
+	      (raise-exception os-error 0 channel (get-error-string status key))
+	      (goto return-boolean ready?)))
+	(raise-exception wrong-type-argument 0 channel))))
+
 (define (channel-read-or-write read? proc)
   (lambda (thing start count wait? channel key)
     (let ((lose (lambda (reason)
diff --git a/scheme/vm/ps-channel.scm b/scheme/vm/ps-channel.scm
index c0eaaa5..4050375 100644
--- a/scheme/vm/ps-channel.scm
+++ b/scheme/vm/ps-channel.scm
@@ -44,6 +44,13 @@
 (define close-input-channel close-channel)
 (define close-output-channel close-channel)
 
+; (channel-ready? channel read?)
+;       -> ready? status
+
+(define channel-ready?
+  (external "ps_check_fd"
+	    (=> (integer boolean) boolean integer)))
+
 ; Read and writing blocks of data
 ;
 ; (channel-read-block channel buffer count wait?)
diff --git a/scheme/vm/s48-channel.scm b/scheme/vm/s48-channel.scm
index a61eda9..143a873 100644
--- a/scheme/vm/s48-channel.scm
+++ b/scheme/vm/s48-channel.scm
@@ -76,6 +76,12 @@
 (define (close-output-channel channel)
   ((structure-ref prescheme close-output-port) (channel->port channel)))
 
+(define (channel-ready? channel read?)
+  (values (if read?
+	      (char-ready? (channel->port channel))
+	      #t)
+	  (enum (structure-ref prescheme errors) no-errors)))
+
 ;----------------
 ; Non-blocking I/O (implemented using CHAR-READY?)
 ;
diff --git a/scsh/newports.scm b/scsh/newports.scm
index b7b20a8..dd0f5a2 100644
--- a/scsh/newports.scm
+++ b/scsh/newports.scm
@@ -30,7 +30,7 @@
   (let* ((fdport* (fdport-data fdport))
 	 (ch (fdport-data:channel fdport*))
 	 (ch-number  (channel-os-index ch)))
-    (if (fdport-data:revealed fdport*)
+    (if (not (= (fdport-data:revealed fdport*) 0))
 	(vector-set! fdports ch-number fdport)
 	(weak-vector-set! fdports ch-number fdport))))
 
@@ -46,6 +46,12 @@
   (eq? (channel-status (fdport-data:channel fdport*)) 
        (enum channel-status-option closed)))
 
+;;; Support for channel-ready?
+;;; This applies to input- and output-ports
+
+(define (fdport-channel-ready? fdport*)
+  (channel-ready? (fdport-data: channel fdport*)))
+
 ;Arbitrary, for now.
 (define buffer-size 255)
 
@@ -59,8 +65,9 @@
 
 ;The two following routines are to build ports from stdin and stdout channels.
 (define (channel-port->input-fdport channel-port)
-  (let ((p (make-input-port input-fdport-handler
-			    (make-fdport-data (channel-cell-ref (port-data channel-port)) 1)
+  (let ((p (make-buffered-input-port input-fdport-handler
+			    (make-fdport-data
+			     (channel-cell-ref (port-data channel-port)) 1)
 			    (make-byte-vector buffer-size 0) 0 0)))
     (obtain-port-lock channel-port)
     (set-port-lock! p (port-lock channel-port))
@@ -70,9 +77,10 @@
     p))
 
 (define (channel-port->output-fdport channel-port)
-  (let ((p (make-output-port output-fdport-handler
-			     (make-fdport-data  (channel-cell-ref(port-data channel-port)) 1)
-			     (make-byte-vector buffer-size 0) 0 buffer-size)))
+  (let ((p (make-buffered-output-port 
+	    output-fdport-handler
+	    (make-fdport-data  (channel-cell-ref(port-data channel-port)) 1)
+	    (make-byte-vector buffer-size 0) 0 buffer-size)))
     (obtain-port-lock channel-port)
     (set-port-lock! p (port-lock channel-port))
     (set-port-locked?! p (port-locked? channel-port))
@@ -83,22 +91,23 @@
 
 (define (channel-port->unbuffered-output-fdport channel-port)
   (let ((p (make-unbuffered-output-port unbuffered-output-fdport-handler
-			     (make-fdport-data  (channel-cell-ref(port-data channel-port)) 1))))
+			     (make-fdport-data 
+			      (channel-cell-ref (port-data channel-port)) 1))))
     (obtain-port-lock channel-port)
     (set-port-lock! p (port-lock channel-port))
     (set-port-locked?! p (port-locked? channel-port))
     (install-fdport p)
-   ; (periodically-force-output! p)
+    (periodically-force-output! p)
     (release-port-lock channel-port)
     p))
 
 (define (alloc-input-fdport fd revealed)
-  (make-input-port input-fdport-handler
+  (make-buffered-input-port input-fdport-handler
 		   (make-fdport-data (make-input-fdchannel fd) revealed)
 		   (make-byte-vector buffer-size 0) 0 0))
 
 (define (alloc-output-fdport fd revealed)
-  (make-output-port output-fdport-handler
+  (make-buffered-output-port output-fdport-handler
 		    (make-fdport-data (make-output-fdchannel fd) revealed)
 		    (make-byte-vector buffer-size 0) 0 buffer-size))
 
@@ -109,7 +118,7 @@
 
 (define (make-output-fdport fd revealed)
   (let ((p (alloc-output-fdport fd revealed)))
-    ;(periodically-force-output! p)
+    (periodically-force-output! p)
     (install-fdport p)
     p))
 
@@ -129,11 +138,12 @@
 
 ;The handlers drop straight through to the convenient channel routines.
 (define (make-input-fdport-handler bufferproc)
-  (make-port-handler
+  (make-buffered-input-port-handler
    (lambda (fdport*)
      (list 'input-fdport (fdport-data:channel fdport*)))
    close-fdport*
    bufferproc
+   fdport-channel-ready?
    (lambda (fdport* owner)
      (steal-channel! (fdport-data:channel fdport*) owner))))
 
@@ -143,11 +153,12 @@
      (channel-read buffer start needed (fdport-data:channel fdport*)))))
 
 (define (make-output-fdport-handler bufferproc)
-   (make-port-handler
+   (make-buffered-output-port-handler
    (lambda (fdport*)
      (list 'output-fdport (fdport-data:channel fdport*)))
    close-fdport*
    bufferproc
+   fdport-channel-ready?
    (lambda (fdport* owner)
      (steal-channel! (fdport-data:channel fdport*) owner))))
 
@@ -167,21 +178,7 @@
 ; That was easy.
 
 
-(define (06-policy policy)
-  (case policy
-    ((0) 'bufpol/block)
-    ((1) 'bufpol/line)
-    ((2) 'bufpol/none)
-    (else policy)))
-
-(define (guess-output-policy port)
-  (if (= 0 (port-limit port)) 
-      'bufpol/none
-      'bufpol/block))
-      
-
 (define (set-port-buffering port policy . maybe-size) 
-  (let ((policy (06-policy policy)))
   (cond ((and (fdport? port) (open-input-port? port))
 	 (let ((size (if (pair? maybe-size) (car maybe-size) 255)))
 	   (set-input-port-buffering port policy size)))
@@ -190,12 +187,12 @@
 	    (if (<= size 0) (error "size must be at least 1"))
 	   (set-output-port-buffering port policy size)))
 	(else
-            (warn "port-type not supported" port)))))
+            (warn "port-type not supported" port))))
 
 (define (set-output-port-buffering port policy size) 
-  (cond ((eq? policy 'bufpol/none)
+  (cond ((eq? policy bufpol/none)
 	 (install-nullbuffer port unbuffered-output-fdport-handler))
-	((eq? policy 'bufpol/block)
+	((eq? policy bufpol/block)
 	 (let ((old-size (byte-vector-length (port-buffer port)))
 	       (new-buffer (make-byte-vector size 0)))
 	   (if (< size old-size)
@@ -208,7 +205,7 @@
 		 (copy-bytes! (port-buffer port) 0 new-buffer 0 old-size)))
 	   (install-buffer port new-buffer size)
 	   (release-port-lock port)))
-	((eq? policy 'bufpol/line)
+	((eq? policy bufpol/line)
 	 (install-nullbuffer port (make-line-output-proc size)))
 	(else (warn "policy not supported " policy))))
 
@@ -222,7 +219,7 @@
  (release-port-lock port))
 
 (define (install-buffer port new-buffer size)
-  (if (eq? 'bufpol/none (guess-output-policy port))
+  (if (eq? bufpol/none (guess-output-policy port))
       (set-port-handler! port output-fdport-handler))
   (set-port-limit! port size)
   (set-port-buffer! port new-buffer))
@@ -234,7 +231,7 @@
 (define (make-line-output-proc size)
   (let ((proc-buffer (make-byte-vector size 0))
 	(proc-buffer-index 0))
-    (make-port-handler
+    (make-buffered-output-port-handler
      (lambda (fdport*)
        (list 'output-fdport (fdport-data:channel fdport*)))
      (lambda (fdport*)
@@ -252,17 +249,18 @@
 			     proc-buffer-index 
 			     (fdport-data:channel fdport*))
 	      (set! proc-buffer-index 0))))
+     fdport-channel-ready?
      (lambda (fdport* owner)
        (steal-channel! (fdport-data:channel fdport*) owner)))))
 
 	
 (define (set-input-port-buffering port policy size)
-  (cond ((eq? policy 'bufpol/none)
-	 (set-input-port-buffering port 'bufpol/block 1))
-	((eq? policy 'bufpol/block)
+  (cond ((eq? policy bufpol/none)
+	 (set-input-port-buffering port bufpol/block 1))
+	((eq? policy bufpol/block)
 	 (if (<= size 0) (error "size must be at least 1"))
 	 (install-input-handler port input-fdport-handler size #t))
-	((eq? policy 'bufpol/line)
+	((eq? policy bufpol/line)
 	 (error "bufpol/line not allowed on input"))
 	(else (warn "policy not supported " policy))))
 
@@ -476,10 +474,13 @@
       (set! old-outport (current-output-port)))
   (if (not (fdport? (current-error-port)))
       (set! old-errport (current-error-port)))
-  (set-fluid! $current-input-port  (channel-port->input-fdport (current-input-port)))
-  (set-fluid! $current-output-port (channel-port->output-fdport (current-output-port)))
+  (set-fluid! $current-input-port  
+	      (channel-port->input-fdport (current-input-port)))
+  (set-fluid! $current-output-port 
+	      (channel-port->output-fdport (current-output-port)))
   
-  (set-fluid! $current-error-port  (channel-port->unbuffered-output-fdport (current-error-port)))
+  (set-fluid! $current-error-port  
+	      (channel-port->unbuffered-output-fdport (current-error-port)))
   (set-fluid! $current-noise-port  (make-null-output-port)))
 
 ;;; Generic port operations
@@ -672,4 +673,4 @@
     (lambda (port)
       (let-fluid $current-output-port port thunk))))
 
-;;; replace rts/channel-port.scm end
\ No newline at end of file
+;;; replace rts/channel-port.scm end