> Earlier, I wrote:
>> I'm not sure off-hand what would be required to re-implement custom
>> ports in suspendable Scheme code.
>
> I finally dug into this code, and was delighted to find that Andy Wingo
> has already laid the groundwork to avoid going through C code in our
> custom port handlers, in commit 8bad621fec65d58768a38661278165ae259fabce
> from April 2016:
>
>
> https://git.savannah.gnu.org/cgit/guile.git/commit/?id=8bad621fec65d58768a38661278165ae259fabce
>
> Given this, I think it will be fairly straightforward to modify our
> custom ports to be suspendable. Likewise, I see no difficulty in
> implementing a suspendable version of 'get-bytevector-some'.
>
> I'll work on it.
Here are preliminary patches to implement suspendable custom ports and
'get-bytevector-some', although I haven't yet given them much testing.
Mark
>From 271cbbc3acc40926c8311e8dcca757285a53f00d Mon Sep 17 00:00:00 2001
From: Mark H Weaver <m...@netris.org>
Date: Sun, 14 Apr 2019 17:43:30 -0400
Subject: [PATCH] DRAFT: Add a suspendable implementation of
'get-bytevector-some'.
---
module/ice-9/suspendable-ports.scm | 17 +++++++++++++++--
1 file changed, 15 insertions(+), 2 deletions(-)
diff --git a/module/ice-9/suspendable-ports.scm b/module/ice-9/suspendable-ports.scm
index a366c8b9c..d91ffd3c1 100644
--- a/module/ice-9/suspendable-ports.scm
+++ b/module/ice-9/suspendable-ports.scm
@@ -1,5 +1,5 @@
;;; Ports, implemented in Scheme
-;;; Copyright (C) 2016 Free Software Foundation, Inc.
+;;; Copyright (C) 2016, 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 as
@@ -292,6 +292,19 @@
((< (- count pos) (port-read-buffering port)) (buffer-and-fill pos))
(else (fill-directly pos))))))
+(define (get-bytevector-some port)
+ (call-with-values (lambda () (fill-input port 1 'binary))
+ (lambda (buf cur buffered)
+ (if (zero? buffered)
+ (begin
+ (set-port-buffer-has-eof?! buf #f)
+ the-eof-object)
+ (let ((result (make-bytevector buffered)))
+ (bytevector-copy! (port-buffer-bytevector buf) cur
+ result 0 buffered)
+ (set-port-buffer-cur! buf (+ cur buffered))
+ result)))))
+
(define (put-u8 port byte)
(let* ((buf (port-write-buffer port))
(bv (port-buffer-bytevector buf))
@@ -702,7 +715,7 @@
read-char peek-char force-output close-port
accept connect)
((ice-9 binary-ports)
- get-u8 lookahead-u8 get-bytevector-n
+ get-u8 lookahead-u8 get-bytevector-n get-bytevector-some
put-u8 put-bytevector)
((ice-9 textual-ports)
put-char put-string)
--
2.21.0
>From 57b1cb09a9c7b553ce35782605016430a355e237 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <m...@netris.org>
Date: Sun, 14 Apr 2019 17:30:40 -0400
Subject: [PATCH] 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 c1cbbdf30..577bcdffd 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);
@@ -892,28 +880,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,
@@ -924,6 +890,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);
@@ -947,9 +916,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);
@@ -996,6 +967,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);
@@ -1020,10 +994,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,
@@ -1035,6 +1013,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;
@@ -1160,15 +1188,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 e0da3df1a..6389c9be8 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
@@ -45,6 +45,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
