scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Adapted some of Richard's changes for char-ready? and output-port-ready?.

This commit is contained in:
mainzelm 2001-03-23 10:59:07 +00:00
parent 0ffb123bee
commit 9b4bb8a19d
14 changed files with 305 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
c/fd-io.h
View File

@ -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);

29
c/unix/fd-io.c
View File

@ -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)

40
scheme/big/more-port.scm
View File

@ -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,18 +178,19 @@
; 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
(make-buffered-input-port string-input-port-handler
#f ; no additional state needed
buffer
0
@ -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,7 +248,8 @@
b))))
(define (make-string-output-port)
(let ((port (make-output-port string-output-port-handler
(let ((port (make-buffered-output-port
string-output-port-handler
(list #f)
(make-code-vector default-buffer-size 0)
0
@ -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)

26
scheme/interfaces.scm
View File

@ -162,6 +162,8 @@
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

4
scheme/packages.scm
View File

@ -291,8 +291,8 @@
methods
meta-methods
interrupts
events
events-internal
sigevents
sigevents-internal
low-level
more-types
number-i/o

10
scheme/rts-packages.scm
View File

@ -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

18
scheme/rts/channel-port.scm
View File

@ -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-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,6 +75,8 @@
(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)
(channel-ready? (channel-cell-ref channel-cell)))
(lambda (channel-cell owner)
(steal-channel! (channel-cell-ref channel-cell) owner)))))
@ -96,7 +103,8 @@
(make-unbuffered-output-port (make-unbuffered-output-channel-handler)
(make-channel-cell channel closer)))
(else
(let ((port (make-output-port output-channel-handler
(let ((port (make-buffered-output-port
output-channel-handler
(make-channel-cell channel closer)
(make-code-vector buffer-size 0)
0

149
scheme/rts/port.scm
View File

@ -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!))

1
scheme/vm/arch.scm
View File

@ -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

1
scheme/vm/interfaces.scm
View File

@ -399,6 +399,7 @@
output-channel->port
close-input-channel
close-output-channel
channel-ready?
channel-read-block
channel-write-block
channel-abort

12
scheme/vm/prim-io.scm
View File

@ -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)

7
scheme/vm/ps-channel.scm
View File

@ -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?)

6
scheme/vm/s48-channel.scm
View File

@ -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?)
;

77
scsh/newports.scm
View File

@ -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,7 +77,8 @@
p))
(define (channel-port->output-fdport channel-port)
(let ((p (make-output-port output-fdport-handler
(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)
@ -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