mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +02:00
peek-byte in Scheme
* libguile/ports.c (trampoline_to_c_read, trampoline_to_c_write): Since C might assume that the indices are within bounds of the bytevector, verify them more here. (scm_port_random_access_p, scm_port_read_buffering) (scm_set_port_read_buffer, scm_port_read, scm_port_write): New helpers exposed to (ice-9 ports). (scm_port_read_buffer, scm_port_write_buffer): Don't flush or validate port mode; we do that in Scheme. * module/ice-9/ports.scm: Implement enough of port machinery to implement peek-byte in Scheme. Not yet exported.
This commit is contained in:
Andy Wingo
parent
300c85b0f0
commit
6a752bcf2a
3 changed files with 169 additions and 30 deletions
110
libguile/ports.c
110
libguile/ports.c
|
|
@ -258,11 +258,20 @@ scm_make_port_type (char *name,
|
|||
|
||||
static SCM
|
||||
trampoline_to_c_read (SCM port, SCM dst, SCM start, SCM count)
|
||||
#define FUNC_NAME "port-read"
|
||||
{
|
||||
size_t c_start, c_count;
|
||||
|
||||
SCM_VALIDATE_OPPORT (1, port);
|
||||
c_start = scm_to_size_t (start);
|
||||
c_count = scm_to_size_t (count);
|
||||
SCM_ASSERT_RANGE (2, start, start <= count);
|
||||
SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (dst));
|
||||
|
||||
return scm_from_size_t
|
||||
(SCM_PORT_DESCRIPTOR (port)->c_read
|
||||
(port, dst, scm_to_size_t (start), scm_to_size_t (count)));
|
||||
(SCM_PORT_DESCRIPTOR (port)->c_read (port, dst, c_start, c_count));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static size_t
|
||||
trampoline_to_scm_read (SCM port, SCM dst, size_t start, size_t count)
|
||||
|
|
@ -274,11 +283,20 @@ trampoline_to_scm_read (SCM port, SCM dst, size_t start, size_t count)
|
|||
|
||||
static SCM
|
||||
trampoline_to_c_write (SCM port, SCM src, SCM start, SCM count)
|
||||
#define FUNC_NAME "port-write"
|
||||
{
|
||||
size_t c_start, c_count;
|
||||
|
||||
SCM_VALIDATE_OPPORT (1, port);
|
||||
c_start = scm_to_size_t (start);
|
||||
c_count = scm_to_size_t (count);
|
||||
SCM_ASSERT_RANGE (2, start, c_start <= c_count);
|
||||
SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (src));
|
||||
|
||||
return scm_from_size_t
|
||||
(SCM_PORT_DESCRIPTOR (port)->c_write
|
||||
(port, src, scm_to_size_t (start), scm_to_size_t (count)));
|
||||
(SCM_PORT_DESCRIPTOR (port)->c_write (port, src, c_start, c_count));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static size_t
|
||||
trampoline_to_scm_write (SCM port, SCM src, size_t start, size_t count)
|
||||
|
|
@ -2457,43 +2475,75 @@ scm_fill_input (SCM port)
|
|||
return read_buf;
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_port_random_access_p, "port-random-access?", 1, 0, 0,
|
||||
(SCM port),
|
||||
"Return true if the port is random-access, or false otherwise.")
|
||||
#define FUNC_NAME s_scm_port_random_access_p
|
||||
{
|
||||
SCM_VALIDATE_OPPORT (1, port);
|
||||
return scm_from_bool (SCM_PTAB_ENTRY (port)->rw_random);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_port_read_buffering, "port-read-buffering", 1, 0, 0,
|
||||
(SCM port),
|
||||
"Return the amount of read buffering on a port, in bytes.")
|
||||
#define FUNC_NAME s_scm_port_read_buffering
|
||||
{
|
||||
SCM_VALIDATE_OPINPORT (1, port);
|
||||
return scm_from_size_t (SCM_PTAB_ENTRY (port)->read_buffering);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_set_port_read_buffer_x, "set-port-read-buffer!", 2, 0, 0,
|
||||
(SCM port, SCM buf),
|
||||
"Reset the read buffer on an input port.")
|
||||
#define FUNC_NAME s_scm_set_port_read_buffer_x
|
||||
{
|
||||
SCM_VALIDATE_OPINPORT (1, port);
|
||||
SCM_ASSERT_TYPE (scm_is_vector (buf) && scm_c_vector_length (buf) >= 4,
|
||||
buf, 2, FUNC_NAME, "port buffer");
|
||||
SCM_PTAB_ENTRY (port)->read_buf = buf;
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_port_read, "port-read", 1, 0, 0, (SCM port),
|
||||
"Return the read function for an input port.")
|
||||
#define FUNC_NAME s_scm_port_read
|
||||
{
|
||||
SCM_VALIDATE_OPINPORT (1, port);
|
||||
return SCM_PORT_DESCRIPTOR (port)->scm_read;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_port_write, "port-write", 1, 0, 0,
|
||||
(SCM port),
|
||||
"Return the write function for an output port.")
|
||||
#define FUNC_NAME s_scm_port_write
|
||||
{
|
||||
SCM_VALIDATE_OPOUTPORT (1, port);
|
||||
return SCM_PORT_DESCRIPTOR (port)->scm_write;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_port_read_buffer, "port-read-buffer", 1, 0, 0,
|
||||
(SCM port),
|
||||
"Return the read buffer for a port. If the port is\n"
|
||||
"random-access, its write buffer, if any, will be flushed\n"
|
||||
"if needed.")
|
||||
"Return the read buffer for a port.")
|
||||
#define FUNC_NAME s_scm_port_read_buffer
|
||||
{
|
||||
scm_t_port *pt;
|
||||
|
||||
SCM_VALIDATE_OPINPORT (1, port);
|
||||
|
||||
pt = SCM_PTAB_ENTRY (port);
|
||||
|
||||
if (pt->rw_random)
|
||||
scm_flush (pt->port);
|
||||
|
||||
return pt->read_buf;
|
||||
SCM_VALIDATE_OPPORT (1, port);
|
||||
return SCM_PTAB_ENTRY (port)->read_buf;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_port_write_buffer, "port-write-buffer", 1, 0, 0,
|
||||
(SCM port),
|
||||
"Return the write buffer for a port. If the port is\n"
|
||||
"random-access, its read buffer, if any, will be discarded\n"
|
||||
"if needed.")
|
||||
"Return the write buffer for a port.")
|
||||
#define FUNC_NAME s_scm_port_write_buffer
|
||||
{
|
||||
scm_t_port *pt;
|
||||
|
||||
SCM_VALIDATE_OPOUTPORT (1, port);
|
||||
|
||||
pt = SCM_PTAB_ENTRY (port);
|
||||
|
||||
if (pt->rw_random)
|
||||
scm_end_input (pt->port);
|
||||
|
||||
return pt->write_buf;
|
||||
SCM_VALIDATE_OPPORT (1, port);
|
||||
return SCM_PTAB_ENTRY (port)->write_buf;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
|
|||
|
|
@ -316,6 +316,12 @@ SCM_API SCM scm_drain_input (SCM port);
|
|||
SCM_API void scm_end_input (SCM port);
|
||||
SCM_API SCM scm_force_output (SCM port);
|
||||
SCM_API void scm_flush (SCM port);
|
||||
|
||||
SCM_INTERNAL SCM scm_port_random_access_p (SCM port);
|
||||
SCM_INTERNAL SCM scm_port_read_buffering (SCM port);
|
||||
SCM_INTERNAL SCM scm_set_port_read_buffer_x (SCM port, SCM buf);
|
||||
SCM_INTERNAL SCM scm_port_read (SCM port);
|
||||
SCM_INTERNAL SCM scm_port_write (SCM port);
|
||||
SCM_INTERNAL SCM scm_port_read_buffer (SCM port);
|
||||
SCM_INTERNAL SCM scm_port_write_buffer (SCM port);
|
||||
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@
|
|||
|
||||
|
||||
(define-module (ice-9 ports)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:export (;; Definitions from ports.c.
|
||||
%port-property
|
||||
%set-port-property!
|
||||
|
|
@ -153,6 +154,88 @@
|
|||
|
||||
|
||||
|
||||
(define-syntax-rule (port-buffer-bytevector buf) (vector-ref buf 0))
|
||||
(define-syntax-rule (port-buffer-cur buf) (vector-ref buf 1))
|
||||
(define-syntax-rule (port-buffer-end buf) (vector-ref buf 2))
|
||||
(define-syntax-rule (port-buffer-has-eof? buf) (vector-ref buf 3))
|
||||
|
||||
(define-syntax-rule (set-port-buffer-cur! buf cur)
|
||||
(vector-set! buf 1 cur))
|
||||
(define-syntax-rule (set-port-buffer-end! buf end)
|
||||
(vector-set! buf 2 end))
|
||||
(define-syntax-rule (set-port-buffer-has-eof?! buf has-eof?)
|
||||
(vector-set! buf 3 has-eof?))
|
||||
|
||||
(define (make-port-buffer size)
|
||||
(vector (make-bytevector size 0) 0 0 #f))
|
||||
|
||||
(define (write-bytes port src start count)
|
||||
(let ((written ((port-write port) port src start count)))
|
||||
(unless (<= 0 written count)
|
||||
(error "bad return from port write function" written))
|
||||
(when (< written count)
|
||||
(write-bytes port src (+ start written) (- count written)))))
|
||||
|
||||
(define (flush-output port)
|
||||
(let* ((buf (port-write-buffer port))
|
||||
(cur (port-buffer-cur buf))
|
||||
(end (port-buffer-end buf)))
|
||||
(when (< cur end)
|
||||
;; Update cursors before attempting to write, assuming that I/O
|
||||
;; errors are sticky. That way if the write throws an error,
|
||||
;; causing the computation to abort, and possibly causing the port
|
||||
;; to be collected by GC when it's open, any subsequent close-port
|
||||
;; or force-output won't signal *another* error.
|
||||
(set-port-buffer-cur! buf 0)
|
||||
(set-port-buffer-end! buf 0)
|
||||
(write-bytes port (port-buffer-bytevector buf) cur (- end cur)))))
|
||||
|
||||
(define (read-bytes port dst start count)
|
||||
(let ((read ((port-read port) port dst start count)))
|
||||
(unless (<= 0 read count)
|
||||
(error "bad return from port read function" read))
|
||||
read))
|
||||
|
||||
(define (fill-input port)
|
||||
(let ((buf (port-read-buffer port)))
|
||||
(cond
|
||||
((or (< (port-buffer-cur buf) (port-buffer-end buf))
|
||||
(port-buffer-has-eof? buf))
|
||||
buf)
|
||||
(else
|
||||
(unless (input-port? port)
|
||||
(error "not an input port" port))
|
||||
(when (port-random-access? port)
|
||||
(flush-output port))
|
||||
(let* ((read-buffering (port-read-buffering port))
|
||||
(buf (if (= (bytevector-length (port-buffer-bytevector buf))
|
||||
read-buffering)
|
||||
buf
|
||||
(let ((buf (make-port-buffer read-buffering)))
|
||||
(set-port-read-buffer! port buf)
|
||||
buf)))
|
||||
(bv (port-buffer-bytevector buf))
|
||||
(start (port-buffer-end buf))
|
||||
(count (- (bytevector-length bv) start))
|
||||
(read (read-bytes port bv start count)))
|
||||
(set-port-buffer-end! buf (+ start read))
|
||||
(set-port-buffer-has-eof?! buf (zero? count))
|
||||
buf)))))
|
||||
|
||||
(define (peek-byte port)
|
||||
(let* ((buf (port-read-buffer port))
|
||||
(cur (port-buffer-cur buf)))
|
||||
(if (< cur (port-buffer-end buf))
|
||||
(bytevector-u8-ref (port-buffer-bytevector buf) cur)
|
||||
(let* ((buf (fill-input port))
|
||||
(cur (port-buffer-cur buf)))
|
||||
(if (< cur (port-buffer-end buf))
|
||||
(bytevector-u8-ref (port-buffer-bytevector buf) cur)
|
||||
the-eof-object)))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;; Current ports as parameters.
|
||||
;;;
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue