From 6a752bcf2ae78ee1ce25512a7c65307a909e99e1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 30 Apr 2016 14:46:45 +0200 Subject: [PATCH] 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. --- libguile/ports.c | 110 ++++++++++++++++++++++++++++++----------- libguile/ports.h | 6 +++ module/ice-9/ports.scm | 83 +++++++++++++++++++++++++++++++ 3 files changed, 169 insertions(+), 30 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 058d7dcf3..319b5f5fa 100644 --- a/libguile/ports.c +++ b/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 diff --git a/libguile/ports.h b/libguile/ports.h index ba4bc2c3a..2a6e42c8b 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -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); diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 388b2584a..8051549eb 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -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. ;;;