suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add port shortcut for `make-{input,output}-port'

Browse Source 
Providing a port instead of a reading or writing procedure
redirects the read/write to the specified port. This shortcut
is kind of a hack, but the run-time system can easily streamline
the redirection when it's exposed this way.

Using the new redirection feature reduces overhead in
`with-output-to-bytes' and `pretty-print'.
This commit is contained in:
Matthew Flatt 2012-08-28 08:35:01 -06:00
parent 2c93ccdf18
commit 763882f651
8 changed files with 364 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/racket/port.rkt
View File

@ -605,9 +605,15 @@
(lambda (p location-proc pos [close? #t] [count-lines!-proc void])
(make-input-port
(object-name p)
p ;; redirect `read' to `p'
;; Here's the long way to redirect:
#;
(lambda (s)
(let ([v (read-bytes-avail!* s p)])
(if (eq? v 0) (wrap-evt p (lambda (x) 0)) v)))
p ;; redirect `peek' to `p'
;; Here's the long way to redirect:
#;
(lambda (s skip evt)
(let ([v (peek-bytes-avail!* s skip evt p)])
(if (eq? v 0)

6
collects/racket/private/port.rkt
View File

@ -55,6 +55,9 @@
(make-output-port
(object-name p)
p
p ; `write' just redirects to `p'
;; Here's the slow way to redirect:
#;
(lambda (s start end nonblock? breakable?)
(if (= start end)
(parameterize-break
@ -75,6 +78,9 @@
(when close?
(close-output-port p)))
(and (port-writes-special? p)
p ; `write-special' just redirects to `p'
;; Here's the slow way to redirect:
#;
(lambda (special nonblock? breakable?)
((if nonblock?
write-special-avail*

70
collects/scribblings/reference/custom-ports.scrbl
View File

@ -10,17 +10,21 @@ obtain fine control over the action of committing bytes as read or
written.
@defproc[(make-input-port [name any/c]
[read-in (bytes?
. -> . (or/c exact-nonnegative-integer?
eof-object?
procedure?
evt?))]
[peek (bytes? exact-nonnegative-integer? (or/c evt? #f)
. -> . (or/c exact-nonnegative-integer?
eof-object?
procedure?
evt?
#f))]
[read-in (or/c
(bytes?
. -> . (or/c exact-nonnegative-integer?
eof-object?
procedure?
evt?))
input-port?)]
[peek (or/c
(bytes? exact-nonnegative-integer? (or/c evt? #f)
. -> . (or/c exact-nonnegative-integer?
eof-object?
procedure?
evt?
#f))
input-port?)]
[close (-> any)]
[get-progress-evt (or/c (-> evt?) #f) #f]
[commit (or/c (exact-positive-integer? evt? evt? . -> . any)
@ -52,7 +56,9 @@ The arguments implement the port as follows:
@item{@racket[name] --- the name for the input port.}
@item{@racket[read-in] --- a procedure that takes a single argument:
@item{@racket[read-in] --- either an input port, in which case reads
are redirected to the given port, or a procedure that takes a single
argument:
a mutable byte string to receive read bytes. The procedure's
result is one of the following:
@itemize[
@ -146,10 +152,14 @@ The arguments implement the port as follows:
@racket[get-progress-evt], and @racket[commit]
procedures, however, and even an implementor who does supply
them may provide a different @racket[read-in]
that uses a fast path for non-blocking reads.}
that uses a fast path for non-blocking reads.
In an input port is provided for @racket[read-in], then an input port
must also be provided for @racket[peek].}
@item{@racket[peek] --- either @racket[#f] or a procedure
@item{@racket[peek] --- either @racket[#f], an input port (in which
case peeks are redirected to the given port), or a procedure
that takes three arguments:
@itemize[
@ -206,7 +216,10 @@ The arguments implement the port as follows:
@racket[#f], then @racket[progress-evt] and @racket[commit] must
be @racket[#f]. See also @racket[make-input-port/peek-to-read],
which implements peeking in terms of @racket[read-in] without
these constraints.}
these constraints.
In an input port is provided for @racket[peek], then an input port
must also be provided for @racket[read-in].}
@item{@racket[close] --- a procedure of zero arguments that is
called to close the port. The port is not considered closed until
@ -669,20 +682,23 @@ s
@defproc[(make-output-port [name any/c]
[evt evt?]
[write-out (bytes? exact-nonnegative-integer?
exact-nonnegative-integer?
boolean?
boolean?
. -> .
(or/c exact-nonnegative-integer?
#f
evt?))]
[write-out (or/c
(bytes? exact-nonnegative-integer?
exact-nonnegative-integer?
boolean?
boolean?
. -> .
(or/c exact-nonnegative-integer?
#f
evt?))
output-port?)]
[close (-> any)]
[write-out-special (or/c (any/c boolean? boolean?
. -> .
(or/c any/c
#f
evt?))
output-port?
#f)
#f]
[get-write-evt (or/c
@ -735,7 +751,9 @@ procedures.
@racket[always-evt] if writes to the port always succeed without
blocking.}
@item{@racket[write-out] --- a procedure of five arguments:
@item{@racket[write-out] --- either an output port, which indicates that
writes should be redirected to the given port, or a procedure
of five arguments:
@itemize[
@ -849,7 +867,9 @@ procedures.
terminated immediately with an error.}
@item{@racket[write-out-special] --- either @racket[#f] (the
default), or a procedure to handle @racket[write-special] calls
default), an output port (which indicates that
special writes should be redirected to the given port),
or a procedure to handle @racket[write-special] calls
for the port. If @racket[#f], then the port does not support
special output, and @racket[port-writes-special?] will return
@racket[#f] when applied to the port.

32
collects/tests/racket/port.rktl
View File

@ -670,6 +670,38 @@
(write-special-avail* 'any p)
(test '(special #t #f #f) values status))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check port shortcuts for `make-input-port' and `make-output-port'
(let-values ([(i o) (make-pipe 5)])
(define i2 (make-input-port
(object-name i)
i
i
void))
(define o2 (make-output-port
(object-name o)
o
o
void))
(test #f sync/timeout 0 i2)
(test o2 sync/timeout 0 o2)
(write-bytes #"01234" o2)
(test #f sync/timeout 0 o2)
(test i2 sync/timeout 0 i2)
(test #"01234" read-bytes 5 i2)
(test 0 read-bytes-avail!* (make-bytes 3) i2)
(thread (lambda ()
(sync (system-idle-evt))
(write-bytes #"5" o2)))
(test #\5 read-char i2)
(let ([s (make-bytes 6)])
(thread (lambda ()
(sync (system-idle-evt))
(test 5 write-bytes-avail #"6789ab" o2)))
(test 5 read-bytes-avail! s i2)
(test #"6789a\0" values s)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that an uncooperative output port doesn't keep breaks
;; disabled too long:

44
collects/tests/racket/portlib.rktl
View File

@ -285,6 +285,48 @@
(go-stream #t #f #t #t)
(go-stream #t #t #t #t)))
;; Check port shortcuts for `make-input-port' and `make-output-port' with
;; pipes and specials
(let-values ([(i o) (make-pipe-with-specials 5)])
(define i2 (make-input-port
(object-name i)
i
i
void))
(define o2 (make-output-port
(object-name o)
o
o
void
o))
(test #f sync/timeout 0 i2)
(test o2 sync/timeout 0 o2)
(write-bytes #"01234" o2)
(test #f sync/timeout 0 o2)
(test i2 sync/timeout 0 i2)
(test #"01234" read-bytes 5 i2)
(test 0 read-bytes-avail!* (make-bytes 3) i2)
(thread (lambda ()
(sync (system-idle-evt))
(write-bytes #"5" o2)))
(test #\5 read-char i2)
(let ([s (make-bytes 6)])
(thread (lambda ()
(sync (system-idle-evt))
(test 5 write-bytes-avail #"6789ab" o2)))
(test 5 read-bytes-avail! s i2)
(test #"6789a\0" values s))
(test #t port-writes-special? o2)
(write-special 'ok o2)
(test 'ok read-byte-or-special i2)
(test #t write-special-avail* 'ok-again o2)
(test i2 sync i2)
(test 'ok-again read-byte-or-special i2)
(void))
;; make-input-port/read-to-peek
(define (make-list-port #:eof-as-special? [eof-as-special? #f] . l)
(make-input-port/read-to-peek
@ -787,7 +829,7 @@
(port-count-lines! i2)
(test-values '(1 0 1) (lambda () (port-next-location i)))
(test-values '(2 0 2) (lambda () (port-next-location i2)))
(read-byte i)
(test (char->integer #\x) read-byte i)
(test-values '(1 1 2) (lambda () (port-next-location i)))
(test-values '(2 2 4) (lambda () (port-next-location i2)))
(test (file-stream-buffer-mode i) file-stream-buffer-mode i2))

174
src/racket/src/port.c
View File

@ -8206,10 +8206,10 @@ scheme_make_null_output_port(int can_write_special)
static Scheme_Object *redirect_write_bytes_k(void);
static intptr_t
redirect_write_bytes(Scheme_Output_Port *op,
const char *str, intptr_t d, intptr_t len,
int rarely_block, int enable_break)
intptr_t
scheme_redirect_write_bytes(Scheme_Output_Port *op,
const char *str, intptr_t d, intptr_t len,
int rarely_block, int enable_break)
{
/* arbitrary nesting means we can overflow the stack */
#ifdef DO_STACK_CHECK
@ -8231,9 +8231,19 @@ redirect_write_bytes(Scheme_Output_Port *op,
#endif
return scheme_put_byte_string("redirect-output",
(Scheme_Object *)op->port_data,
(Scheme_Object *)op,
str, d, len,
rarely_block);
(enable_break && !rarely_block) ? -1 : rarely_block);
}
static intptr_t
redirect_write_bytes(Scheme_Output_Port *op,
const char *str, intptr_t d, intptr_t len,
int rarely_block, int enable_break)
{
return scheme_redirect_write_bytes(scheme_output_port_record((Scheme_Object *)op->port_data),
str, d, len,
rarely_block, enable_break);
}
static Scheme_Object *redirect_write_bytes_k(void)
@ -8250,7 +8260,57 @@ static Scheme_Object *redirect_write_bytes_k(void)
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
n = redirect_write_bytes(op, str, d, len, rarely_block, enable_break);
n = scheme_redirect_write_bytes(op, str, d, len, rarely_block, enable_break);
return scheme_make_integer(n);
}
static Scheme_Object *redirect_write_special_k(void);
int scheme_redirect_write_special (Scheme_Output_Port *op, Scheme_Object *v, int nonblock)
{
Scheme_Object *a[2];
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *n;
p->ku.k.p1 = (void *)op;
p->ku.k.p2 = (void *)v;
p->ku.k.i1 = nonblock;
n = scheme_handle_stack_overflow(redirect_write_special_k);
return SCHEME_INT_VAL(n);
}
}
#endif
a[0] = (Scheme_Object *)v;
a[1] = (Scheme_Object *)op;
if (nonblock)
v = scheme_write_special_nonblock(2, a);
else
v = scheme_write_special(2, a);
return SCHEME_TRUEP(v);
}
static Scheme_Object *redirect_write_special_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Output_Port *op = (Scheme_Output_Port *)p->ku.k.p1;
Scheme_Object *v = (Scheme_Object *)p->ku.k.p2;
intptr_t nonblock = p->ku.k.i1;
intptr_t n;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
n = scheme_redirect_write_special(op, v, nonblock);
return scheme_make_integer(n);
}
@ -8279,17 +8339,9 @@ redirect_write_special_evt(Scheme_Output_Port *op, Scheme_Object *special)
static int
redirect_write_special(Scheme_Output_Port *op, Scheme_Object *special, int nonblock)
{
Scheme_Object *v, *a[2];
a[0] = (Scheme_Object *)op->port_data;
a[1] = special;
if (nonblock)
v = scheme_write_special(2, a);
else
v = scheme_write_special(2, a);
return SCHEME_TRUEP(v);
return scheme_redirect_write_special(scheme_output_port_record((Scheme_Object *)op->port_data),
special,
nonblock);
}
Scheme_Object *
@ -8320,6 +8372,92 @@ scheme_make_redirect_output_port(Scheme_Object *port)
return (Scheme_Object *)op;
}
static Scheme_Object *redirect_get_or_peek_bytes_k(void);
intptr_t scheme_redirect_get_or_peek_bytes(Scheme_Input_Port *orig_port,
Scheme_Input_Port *port,
char *buffer, intptr_t offset, intptr_t size,
int nonblock,
int peek, Scheme_Object *peek_skip,
Scheme_Object *unless,
Scheme_Schedule_Info *sinfo)
{
int r;
if (sinfo) {
scheme_set_sync_target(sinfo, (Scheme_Object *)port, (Scheme_Object *)orig_port, NULL, 0, 1, NULL);
return 0;
}
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *n;
p->ku.k.p1 = (void *)port;
p->ku.k.p2 = (void *)buffer;
p->ku.k.p3 = (void *)peek_skip;
p->ku.k.p4 = (void *)unless;
p->ku.k.p4 = (void *)orig_port;
p->ku.k.i1 = offset;
p->ku.k.i1 = size;
p->ku.k.i2 = nonblock;
p->ku.k.i3 = peek;
n = scheme_handle_stack_overflow(redirect_get_or_peek_bytes_k);
return SCHEME_INT_VAL(n);
}
}
#endif
r = scheme_get_byte_string_special_ok_unless("redirect-read-or-peek",
(Scheme_Object *)port,
buffer, offset, size,
((nonblock == -1)
? -1
: (nonblock ? 2 : 1)),
peek, (peek ? peek_skip : NULL),
unless);
if (r == SCHEME_SPECIAL) {
Scheme_Object *res;
res = scheme_get_special_proc((Scheme_Object *)port);
orig_port->special = res;
}
return r;
}
static Scheme_Object *redirect_get_or_peek_bytes_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Input_Port *ip = (Scheme_Input_Port *)p->ku.k.p1;
char *buffer = (char *)p->ku.k.p2;
Scheme_Object *peek_skip = (Scheme_Object *)p->ku.k.p3;
Scheme_Object *unless = (Scheme_Object *)p->ku.k.p4;
Scheme_Input_Port *orig_port = (Scheme_Input_Port *)p->ku.k.p5;
intptr_t d = p->ku.k.i1;
intptr_t len = p->ku.k.i2;
int nonblock = p->ku.k.i3;
int peek = p->ku.k.i4;
intptr_t n;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL;
p->ku.k.p4 = NULL;
p->ku.k.p5 = NULL;
n = scheme_redirect_get_or_peek_bytes(orig_port, ip, buffer, d, len,
nonblock,
peek, peek_skip,
unless, NULL);
return scheme_make_integer(n);
}
/*********** Unix/Windows: process status stuff *************/
#if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES)

75
src/racket/src/portfun.c
View File

@ -895,6 +895,20 @@ user_get_or_peek_bytes(Scheme_Input_Port *port,
intptr_t r;
Scheme_Cont_Frame_Data cframe;
if (peek)
fun = uip->peek_proc;
else
fun = uip->read_proc;
if (SCHEME_INPUT_PORTP(fun)) {
return scheme_redirect_get_or_peek_bytes(port,
scheme_input_port_record(fun),
buffer, offset, size,
nonblock,
peek, peek_skip,
unless, sinfo);
}
val = uip->peeked;
if (val) {
/* Leftover from a read-based peek used to implement `char-ready?'
@ -914,11 +928,6 @@ user_get_or_peek_bytes(Scheme_Input_Port *port,
if (unless && SCHEME_PAIRP(unless))
unless = SCHEME_CDR(unless);
if (peek)
fun = uip->peek_proc;
else
fun = uip->read_proc;
while (1) {
int nb;
@ -971,7 +980,7 @@ user_get_or_peek_bytes(Scheme_Input_Port *port,
/* Call the read/peek function: */
val = scheme_apply(fun, peek ? 3 : 1, a);
if ((size <= MAX_USER_INPUT_REUSE_SIZE)
&& (SCHEME_INTP(val) || SCHEME_EOFP(val) || SCHEME_PROCP(val))) {
uip->reuse_str = bstr;
@ -1375,6 +1384,12 @@ user_write_bytes(Scheme_Output_Port *port, const char *str, intptr_t offset, int
int n, re_enable_break;
Scheme_Cont_Frame_Data cframe;
if (SCHEME_OUTPUT_PORTP(uop->write_proc)) {
return scheme_redirect_write_bytes(scheme_output_port_record(uop->write_proc),
str, offset, len,
rarely_block, enable_break);
}
if (rarely_block)
re_enable_break = 0;
else if (enable_break)
@ -1514,6 +1529,12 @@ user_write_special (Scheme_Output_Port *port, Scheme_Object *v, int nonblock)
int re_enable_break;
Scheme_Cont_Frame_Data cframe;
if (SCHEME_OUTPUT_PORTP(uop->write_special_proc)) {
return scheme_redirect_write_special(scheme_output_port_record(uop->write_special_proc),
v,
nonblock);
}
if (nonblock)
re_enable_break = 0;
else
@ -2228,9 +2249,18 @@ make_input_port(int argc, Scheme_Object *argv[])
Scheme_Input_Port *ip;
User_Input_Port *uip;
Scheme_Object *name;
int read_port, peek_port;
scheme_check_proc_arity("make-input-port", 1, 1, argc, argv); /* read */
scheme_check_proc_arity2("make-input-port", 3, 2, argc, argv, 1); /* peek */
read_port = SCHEME_INPUT_PORTP(argv[1]);
if (!read_port
&& !scheme_check_proc_arity(NULL, 1, 1, argc, argv)) { /* read */
scheme_wrong_contract("make-input-port", "(or/c (procedure-arity-includes/c 1) input-port?)", 1, argc, argv);
}
peek_port = SCHEME_INPUT_PORTP(argv[2]);
if (!peek_port
&& !scheme_check_proc_arity2(NULL, 3, 2, argc, argv, 1)) { /* peek */
scheme_wrong_contract("make-input-port", "(or/c (procedure-arity-includes/c 3) input-port?)", 2, argc, argv);
}
scheme_check_proc_arity("make-input-port", 0, 3, argc, argv); /* close */
if (argc > 4)
scheme_check_proc_arity2("make-input-port", 0, 4, argc, argv, 1); /* progress-evt */
@ -2253,6 +2283,17 @@ make_input_port(int argc, Scheme_Object *argv[])
}
name = argv[0];
/* Shortcut ports for read & peek must be consistent: */
if (!!read_port != !!peek_port) {
scheme_contract_error("make-input-port",
(read_port
? "read argument is an input port, but peek argument is not a port"
: "read argument is not an input port, but peek argument is a port"),
"read argument", 1, argv[1],
"peek argument", 1, argv[2],
NULL);
}
/* It makes no sense to supply progress-evt without peek: */
if ((argc > 5) && SCHEME_FALSEP(argv[2]) && !SCHEME_FALSEP(argv[4]))
scheme_contract_error("make-input-port",
@ -2344,10 +2385,22 @@ make_output_port (int argc, Scheme_Object *argv[])
if (!scheme_is_evt(argv[1])) {
scheme_wrong_contract("make-output-port", "evt?", 1, argc, argv);
}
scheme_check_proc_arity("make-output-port", 5, 2, argc, argv); /* write */
if (!SCHEME_OUTPUT_PORTP(argv[2])
&& !scheme_check_proc_arity(NULL, 5, 2, argc, argv)) { /* write */
scheme_wrong_contract("make-output-port",
"(or/c (procedure-arity-includes/c 5) output-port?)",
2, argc, argv);
}
scheme_check_proc_arity("make-output-port", 0, 3, argc, argv); /* close */
if (argc > 4)
scheme_check_proc_arity2("make-output-port", 3, 4, argc, argv, 1); /* write-special */
if (argc > 4) {
if (!SCHEME_FALSEP(argv[4])
&& !SCHEME_OUTPUT_PORTP(argv[2])
&& !scheme_check_proc_arity(NULL, 3, 4, argc, argv)) { /* write-special */
scheme_wrong_contract("make-output-port",
"(or/c (procedure-arity-includes/c 3) output-port?)",
4, argc, argv);
}
}
if (argc > 5)
scheme_check_proc_arity2("make-output-port", 3, 5, argc, argv, 1); /* write-evt */
if (argc > 6)

12
src/racket/src/schpriv.h
View File

@ -3631,6 +3631,18 @@ intptr_t scheme_port_closed_p (Scheme_Object *port);
#define MAX_UTF8_CHAR_BYTES 6
intptr_t scheme_redirect_write_bytes(Scheme_Output_Port *op,
const char *str, intptr_t d, intptr_t len,
int rarely_block, int enable_break);
int scheme_redirect_write_special (Scheme_Output_Port *op, Scheme_Object *v, int nonblock);
intptr_t scheme_redirect_get_or_peek_bytes(Scheme_Input_Port *orig_port,
Scheme_Input_Port *port,
char *buffer, intptr_t offset, intptr_t size,
int nonblock,
int peek, Scheme_Object *peek_skip,
Scheme_Object *unless,
Scheme_Schedule_Info *sinfo);
/*========================================================================*/
/* memory debugging */
/*========================================================================*/