From 7cbf017e1656a450c5925414df2f0a751a6ba6c2 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 14 Apr 2019 17:30:40 -0400 Subject: [PATCH 4/4] DRAFT: Make custom binary ports suspendable. --- libguile/r6rs-ports.c | 136 +++++++++++++++++++++------------- module/ice-9/binary-ports.scm | 24 +++++- 2 files changed, 107 insertions(+), 53 deletions(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 9b64696a6..9c4f2c8da 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1,4 +1,5 @@ -/* Copyright (C) 2009, 2010, 2011, 2013-2015, 2018 Free Software Foundation, Inc. +/* Copyright (C) 2009-2011, 2013-2015, 2018, 2019 + * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -289,24 +290,6 @@ make_custom_binary_input_port (SCM read_proc, SCM get_position_proc, (scm_t_bits) stream); } -static size_t -custom_binary_input_port_read (SCM port, SCM dst, size_t start, size_t count) -#define FUNC_NAME "custom_binary_input_port_read" -{ - struct custom_binary_port *stream = (void *) SCM_STREAM (port); - SCM octets; - size_t c_octets; - - octets = scm_call_3 (stream->read, dst, scm_from_size_t (start), - scm_from_size_t (count)); - c_octets = scm_to_size_t (octets); - if (c_octets > count) - scm_out_of_range (FUNC_NAME, octets); - - return c_octets; -} -#undef FUNC_NAME - SCM_DEFINE (scm_make_custom_binary_input_port, "make-custom-binary-input-port", 5, 0, 0, @@ -317,6 +300,9 @@ SCM_DEFINE (scm_make_custom_binary_input_port, "index where octets should be written, and an octet count.") #define FUNC_NAME s_scm_make_custom_binary_input_port { + /* Ensure that custom binary ports are initialized. */ + scm_c_resolve_module ("ice-9 binary-ports"); + SCM_VALIDATE_STRING (1, id); SCM_VALIDATE_PROC (2, read_proc); @@ -340,9 +326,11 @@ static inline void initialize_custom_binary_input_ports (void) { custom_binary_input_port_type = - scm_make_port_type ("r6rs-custom-binary-input-port", - custom_binary_input_port_read, NULL); + scm_make_port_type ("r6rs-custom-binary-input-port", NULL, NULL); + scm_set_port_scm_read (custom_binary_input_port_type, + scm_c_private_ref ("ice-9 binary-ports", + "custom-binary-port-read!")); scm_set_port_seek (custom_binary_input_port_type, custom_binary_port_seek); scm_set_port_random_access_p (custom_binary_input_port_type, custom_binary_port_random_access_p); @@ -929,28 +917,6 @@ make_custom_binary_output_port (SCM write_proc, SCM get_position_proc, (scm_t_bits) stream); } -/* Flush octets from BUF to the backing store. */ -static size_t -custom_binary_output_port_write (SCM port, SCM src, size_t start, size_t count) -#define FUNC_NAME "custom_binary_output_port_write" -{ - struct custom_binary_port *stream = (void *) SCM_STREAM (port); - size_t written; - SCM result; - - result = scm_call_3 (stream->write, src, scm_from_size_t (start), - scm_from_size_t (count)); - - written = scm_to_size_t (result); - if (written > count) - scm_wrong_type_arg_msg (FUNC_NAME, 0, result, - "R6RS custom binary output port `write!' " - "returned a incorrect integer"); - - return written; -} -#undef FUNC_NAME - SCM_DEFINE (scm_make_custom_binary_output_port, "make-custom-binary-output-port", 5, 0, 0, @@ -961,6 +927,9 @@ SCM_DEFINE (scm_make_custom_binary_output_port, "index where octets should be written, and an octet count.") #define FUNC_NAME s_scm_make_custom_binary_output_port { + /* Ensure that custom binary ports are initialized. */ + scm_c_resolve_module ("ice-9 binary-ports"); + SCM_VALIDATE_STRING (1, id); SCM_VALIDATE_PROC (2, write_proc); @@ -984,9 +953,11 @@ static inline void initialize_custom_binary_output_ports (void) { custom_binary_output_port_type = - scm_make_port_type ("r6rs-custom-binary-output-port", - NULL, custom_binary_output_port_write); + scm_make_port_type ("r6rs-custom-binary-output-port", NULL, NULL); + scm_set_port_scm_write (custom_binary_output_port_type, + scm_c_private_ref ("ice-9 binary-ports", + "custom-binary-port-write!")); scm_set_port_seek (custom_binary_output_port_type, custom_binary_port_seek); scm_set_port_random_access_p (custom_binary_output_port_type, custom_binary_port_random_access_p); @@ -1033,6 +1004,9 @@ SCM_DEFINE (scm_make_custom_binary_input_output_port, "written, and an octet count.") #define FUNC_NAME s_scm_make_custom_binary_input_output_port { + /* Ensure that custom binary ports are initialized. */ + scm_c_resolve_module ("ice-9 binary-ports"); + SCM_VALIDATE_STRING (1, id); SCM_VALIDATE_PROC (2, read_proc); SCM_VALIDATE_PROC (3, write_proc); @@ -1057,10 +1031,14 @@ static inline void initialize_custom_binary_input_output_ports (void) { custom_binary_input_output_port_type = - scm_make_port_type ("r6rs-custom-binary-input/output-port", - custom_binary_input_port_read, - custom_binary_output_port_write); - + scm_make_port_type ("r6rs-custom-binary-input/output-port", NULL, NULL); + + scm_set_port_scm_read (custom_binary_input_output_port_type, + scm_c_private_ref ("ice-9 binary-ports", + "custom-binary-port-read!")); + scm_set_port_scm_write (custom_binary_input_output_port_type, + scm_c_private_ref ("ice-9 binary-ports", + "custom-binary-port-write!")); scm_set_port_seek (custom_binary_input_output_port_type, custom_binary_port_seek); scm_set_port_random_access_p (custom_binary_input_output_port_type, @@ -1072,6 +1050,56 @@ initialize_custom_binary_input_output_ports (void) +/* Internal accessors needed by 'custom-binary-port-read!' and + 'custom-binary-port-write!'. */ + +SCM_INTERNAL SCM scm_i_custom_binary_port_reader (SCM); +SCM_DEFINE (scm_i_custom_binary_port_reader, + "custom-binary-port-reader", 1, 0, 0, + (SCM port), + "Return the 'read!' procedure associated with PORT, " + "which must be custom binary input or input/output port.") +#define FUNC_NAME s_scm_i_custom_binary_port_reader +{ + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + if (SCM_PORT_TYPE (port) == custom_binary_input_port_type || + SCM_PORT_TYPE (port) == custom_binary_input_output_port_type) + { + struct custom_binary_port *stream = (void *) SCM_STREAM (port); + return stream->read; + } + else + scm_wrong_type_arg_msg (FUNC_NAME, 1, port, + "custom binary input or input/output port"); +} +#undef FUNC_NAME + +SCM_INTERNAL SCM scm_i_custom_binary_port_writer (SCM); +SCM_DEFINE (scm_i_custom_binary_port_writer, + "custom-binary-port-writer", 1, 0, 0, + (SCM port), + "Return the 'write!' procedure associated with PORT, " + "which must be custom binary output or input/output port.") +#define FUNC_NAME s_scm_i_custom_binary_port_writer +{ + SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); + + if (SCM_PORT_TYPE (port) == custom_binary_output_port_type || + SCM_PORT_TYPE (port) == custom_binary_input_output_port_type) + { + struct custom_binary_port *stream = (void *) SCM_STREAM (port); + return stream->write; + } + else + scm_wrong_type_arg_msg (FUNC_NAME, 1, port, + "custom binary output or input/output port"); +} +#undef FUNC_NAME + + + + /* Transcoded ports. */ static scm_t_port_type *transcoded_port_type = 0; @@ -1197,15 +1225,19 @@ scm_register_r6rs_ports (void) NULL); initialize_bytevector_input_ports (); - initialize_custom_binary_input_ports (); initialize_bytevector_output_ports (); - initialize_custom_binary_output_ports (); - initialize_custom_binary_input_output_ports (); initialize_transcoded_ports (); } void scm_init_r6rs_ports (void) { + /* We postpone registering custom binary ports until (ice-9 binary-ports) + * is loaded, because these custom port types depend on Scheme procedures + * defined there. */ + initialize_custom_binary_input_ports (); + initialize_custom_binary_output_ports (); + initialize_custom_binary_input_output_ports (); + #include "libguile/r6rs-ports.x" } diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm index 62fd9786f..70c6577dd 100644 --- a/module/ice-9/binary-ports.scm +++ b/module/ice-9/binary-ports.scm @@ -1,6 +1,6 @@ ;;;; binary-ports.scm --- Binary IO on ports -;;;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2011, 2013, 2019 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -46,6 +46,28 @@ make-custom-binary-output-port make-custom-binary-input/output-port)) +(define (custom-binary-port-read! port bv start count) + (let* ((read! (custom-binary-port-reader port)) + (result (read! bv start count))) + (unless (and (exact-integer? result) + (<= 0 result count)) + (scm-error 'out-of-range #f + "custom port 'read!' (~S) returned value out of range; expected an exact integer between 0 and ~A, got ~A" + (list read! count result) + (list result))) + result)) + +(define (custom-binary-port-write! port bv start count) + (let* ((write! (custom-binary-port-writer port)) + (result (write! bv start count))) + (unless (and (exact-integer? result) + (<= 0 result count)) + (scm-error 'out-of-range #f + "custom port 'write!' (~S) returned value out of range; expected an exact integer between 0 and ~A, got ~A" + (list write! count result) + (list result))) + result)) + ;; Note that this extension also defines %make-transcoded-port, which is ;; not exported but is used by (rnrs io ports). -- 2.21.0