mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Merge commit '8ca97482b0'

Browse source 
Conflicts:
	libguile/r6rs-ports.c
This commit is contained in:
Andy Wingo 2014-02-07 14:42:40 +01:00
commit e4eb0e39b4
3 changed files with 203 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

4
doc/ref/api-io.texi
View file

@ -1792,6 +1792,10 @@ indicating the position of the next byte is to read.
Finally, if @var{close} is not @code{#f}, it must be a thunk. It is
invoked when the custom binary input port is closed.
The returned port is fully buffered by default, but its buffering mode
can be changed using @code{setvbuf} (@pxref{Ports and File Descriptors,
@code{setvbuf}}).
Using a custom binary input port, the @code{open-bytevector-input-port}
procedure could be implemented as follows:

92
libguile/r6rs-ports.c
View file

@ -37,6 +37,7 @@
#include "libguile/validate.h"
#include "libguile/values.h"
#include "libguile/vectors.h"
#include "libguile/ports-internal.h"
@ -272,18 +273,59 @@ cbp_close (SCM port)
static scm_t_bits custom_binary_input_port_type = 0;
/* Size of the buffer embedded in custom binary input ports. */
#define CBIP_BUFFER_SIZE 4096
/* Initial size of the buffer embedded in custom binary input ports. */
#define CBIP_BUFFER_SIZE 8192
/* Return the bytevector associated with PORT. */
#define SCM_CBIP_BYTEVECTOR(_port) \
SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
/* Set BV as the bytevector associated with PORT. */
#define SCM_SET_CBIP_BYTEVECTOR(_port, _bv) \
SCM_SIMPLE_VECTOR_SET (SCM_PACK (SCM_STREAM (_port)), 4, (_bv))
/* Return the various procedures of PORT. */
#define SCM_CBIP_READ_PROC(_port) \
SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
/* Set PORT's internal buffer according to READ_SIZE. */
static void
cbip_setvbuf (SCM port, long read_size, long write_size)
{
SCM bv;
scm_t_port *pt;
pt = SCM_PTAB_ENTRY (port);
bv = SCM_CBIP_BYTEVECTOR (port);
switch (read_size)
{
case 0:
/* Unbuffered: keep PORT's bytevector as is (it will be used in
future 'scm_c_read' calls), but point to the one-byte buffer. */
pt->read_buf = &pt->shortbuf;
pt->read_buf_size = 1;
break;
case -1:
/* Preferred size: keep the current bytevector and use it as the
backing store. */
pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
pt->read_buf_size = SCM_BYTEVECTOR_LENGTH (bv);
break;
default:
/* Fully buffered: allocate a buffer of READ_SIZE bytes. */
bv = scm_c_make_bytevector (read_size);
SCM_SET_CBIP_BYTEVECTOR (port, bv);
pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
pt->read_buf_size = read_size;
}
pt->read_pos = pt->read_end = pt->read_buf;
}
static inline SCM
make_cbip (SCM read_proc, SCM get_position_proc,
SCM set_position_proc, SCM close_proc)
@ -330,26 +372,39 @@ cbip_fill_input (SCM port)
int result;
scm_t_port *c_port = SCM_PTAB_ENTRY (port);
again:
if (c_port->read_pos >= c_port->read_end)
{
/* Invoke the user's `read!' procedure. */
int buffered;
size_t c_octets, c_requested;
SCM bv, read_proc, octets;
c_requested = c_port->read_buf_size;
/* Use the bytevector associated with PORT as the buffer passed to the
`read!' procedure, thereby avoiding additional allocations. */
bv = SCM_CBIP_BYTEVECTOR (port);
read_proc = SCM_CBIP_READ_PROC (port);
/* The assumption here is that C_PORT's internal buffer wasn't changed
behind our back. */
assert (c_port->read_buf ==
(unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
assert ((unsigned) c_port->read_buf_size
== SCM_BYTEVECTOR_LENGTH (bv));
bv = SCM_CBIP_BYTEVECTOR (port);
buffered =
(c_port->read_buf == (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
if (buffered)
/* Make sure the buffer isn't corrupt. BV can be passed directly
to READ_PROC. */
assert (c_port->read_buf_size == SCM_BYTEVECTOR_LENGTH (bv));
else
{
/* This is an unbuffered port. When called via the
'get-bytevector-*' procedures, and thus via 'scm_c_read', we
are passed the caller-provided buffer, so we need to check its
size. */
if (SCM_BYTEVECTOR_LENGTH (bv) < c_requested)
{
/* Bad luck: we have to make another allocation. Save that
bytevector for later reuse, in the hope that the application
has regular access patterns. */
bv = scm_c_make_bytevector (c_requested);
SCM_SET_CBIP_BYTEVECTOR (port, bv);
}
}
octets = scm_call_3 (read_proc, bv, SCM_INUM0,
scm_from_size_t (c_requested));
@ -357,11 +412,15 @@ cbip_fill_input (SCM port)
if (SCM_UNLIKELY (c_octets > c_requested))
scm_out_of_range (FUNC_NAME, octets);
c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
if (!buffered)
/* Copy the data back to the internal buffer. */
memcpy ((char *) c_port->read_pos, SCM_BYTEVECTOR_CONTENTS (bv),
c_octets);
c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
if (c_octets > 0)
goto again;
if (c_octets != 0 || c_requested == 0)
result = (int) *c_port->read_pos;
else
result = EOF;
}
@ -410,6 +469,7 @@ initialize_custom_binary_input_ports (void)
scm_set_port_seek (custom_binary_input_port_type, cbp_seek);
scm_set_port_close (custom_binary_input_port_type, cbp_close);
scm_set_port_setvbuf (custom_binary_input_port_type, cbip_setvbuf);
}

123
test-suite/tests/r6rs-ports.test
View file

@ -456,6 +456,129 @@ not `set-port-position!'"
(u8-list->bytevector
(map char->integer (string->list "Port!")))))))
(pass-if-equal "custom binary input port unbuffered & 'port-position'"
'(0 2 5 11)
;; Check that the value returned by 'port-position' is correct, and
;; that each 'port-position' call leads one call to the
;; 'get-position' method.
(let* ((str "Hello Port!")
(output (make-bytevector (string-length str)))
(source (with-fluids ((%default-port-encoding "UTF-8"))
(open-string-input-port str)))
(read! (lambda (bv start count)
(let ((r (get-bytevector-n! source bv start count)))
(if (eof-object? r)
0
r))))
(pos '())
(get-pos (lambda ()
(let ((p (port-position source)))
(set! pos (cons p pos))
p)))
(port (make-custom-binary-input-port "the port" read!
get-pos #f #f)))
(setvbuf port _IONBF)
(and (= 0 (port-position port))
(begin
(get-bytevector-n! port output 0 2)
(= 2 (port-position port)))
(begin
(get-bytevector-n! port output 2 3)
(= 5 (port-position port)))
(let ((bv (string->utf8 (get-string-all port))))
(bytevector-copy! bv 0 output 5 (bytevector-length bv))
(= (string-length str) (port-position port)))
(bytevector=? output (string->utf8 str))
(reverse pos))))
(pass-if-equal "custom binary input port unbuffered & 'read!' calls"
`((2 "He") (3 "llo") (42 " Port!"))
(let* ((str "Hello Port!")
(source (with-fluids ((%default-port-encoding "UTF-8"))
(open-string-input-port str)))
(reads '())
(read! (lambda (bv start count)
(set! reads (cons count reads))
(let ((r (get-bytevector-n! source bv start count)))
(if (eof-object? r)
0
r))))
(port (make-custom-binary-input-port "the port" read!
#f #f #f)))
(setvbuf port _IONBF)
(let ((ret (list (get-bytevector-n port 2)
(get-bytevector-n port 3)
(get-bytevector-n port 42))))
(zip (reverse reads)
(map (lambda (obj)
(if (bytevector? obj)
(utf8->string obj)
obj))
ret)))))
(pass-if-equal "custom binary input port, unbuffered then buffered"
`((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…")
(777 ,(eof-object)))
(let* ((str "Lorem ipsum dolor sit amet, consectetur…")
(source (with-fluids ((%default-port-encoding "UTF-8"))
(open-string-input-port str)))
(reads '())
(read! (lambda (bv start count)
(set! reads (cons count reads))
(let ((r (get-bytevector-n! source bv start count)))
(if (eof-object? r)
0
r))))
(port (make-custom-binary-input-port "the port" read!
#f #f #f)))
(setvbuf port _IONBF)
(let ((ret (list (get-bytevector-n port 6)
(get-bytevector-n port 12)
(begin
(setvbuf port _IOFBF 777)
(get-bytevector-n port 42))
(get-bytevector-n port 42))))
(zip (reverse reads)
(map (lambda (obj)
(if (bytevector? obj)
(utf8->string obj)
obj))
ret)))))
(pass-if-equal "custom binary input port, buffered then unbuffered"
`((18
42 14 ; scm_c_read tries to fill the 42-byte buffer
42)
("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object)))
(let* ((str "Lorem ipsum dolor sit amet, consectetur bla…")
(source (with-fluids ((%default-port-encoding "UTF-8"))
(open-string-input-port str)))
(reads '())
(read! (lambda (bv start count)
(set! reads (cons count reads))
(let ((r (get-bytevector-n! source bv start count)))
(if (eof-object? r)
0
r))))
(port (make-custom-binary-input-port "the port" read!
#f #f #f)))
(setvbuf port _IOFBF 18)
(let ((ret (list (get-bytevector-n port 6)
(get-bytevector-n port 12)
(begin
(setvbuf port _IONBF)
(get-bytevector-n port 42))
(get-bytevector-n port 42))))
(list (reverse reads)
(map (lambda (obj)
(if (bytevector? obj)
(utf8->string obj)
obj))
ret)))))
(pass-if "custom binary input port `close-proc' is called"
(let* ((closed? #f)
(read! (lambda (bv start count) 0))