From 0e305e6bfda397fbe1e4d2a7c29de6bdbacc206d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 27 May 2023 22:55:40 +0200 Subject: [PATCH] Rewrite custom binary ports in Scheme, in terms of custom ports * libguile/r6rs-ports.c: Call out to Scheme instead of defining here. * libguile/r6rs-ports.h: Put custom binary port decls together, to deprecate later. * module/ice-9/binary-ports.scm: Re-implement custom binary ports in terms of custom ports. --- libguile/r6rs-ports.c | 361 +++------------------------------- libguile/r6rs-ports.h | 6 +- module/ice-9/binary-ports.scm | 115 ++++++++++- 3 files changed, 142 insertions(+), 340 deletions(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 49ca05325..2e4fc9452 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1,4 +1,4 @@ -/* Copyright 2009-2011,2013-2015,2018-2019 +/* Copyright 2009-2011,2013-2015,2018-2019,2023 Free Software Foundation, Inc. This file is part of Guile. @@ -32,6 +32,7 @@ #include "eval.h" #include "extensions.h" #include "gsubr.h" +#include "modules.h" #include "numbers.h" #include "ports-internal.h" #include "procs.h" @@ -194,179 +195,6 @@ SCM_DEFINE (scm_open_bytevector_input_port, #undef FUNC_NAME - - -/* Custom binary ports. The following routines are shared by input and - output custom binary ports. */ - -struct custom_binary_port { - SCM read; - SCM write; - SCM get_position; - SCM set_position_x; - SCM close; -}; - -static int -custom_binary_port_random_access_p (SCM port) -{ - struct custom_binary_port *stream = (void *) SCM_STREAM (port); - - return scm_is_true (stream->set_position_x); -} - -static scm_t_off -custom_binary_port_seek (SCM port, scm_t_off offset, int whence) -#define FUNC_NAME "custom_binary_port_seek" -{ - SCM result; - struct custom_binary_port *stream = (void *) SCM_STREAM (port); - scm_t_off c_result = 0; - - switch (whence) - { - case SEEK_CUR: - { - if (SCM_LIKELY (scm_is_true (stream->get_position))) - result = scm_call_0 (stream->get_position); - else - scm_wrong_type_arg_msg (FUNC_NAME, 0, port, - "R6RS custom binary port with " - "`port-position' support"); - c_result = scm_to_off_t (result); - if (offset == 0) - /* We just want to know the current position. */ - break; - - if (INT_ADD_OVERFLOW (offset, c_result)) - scm_num_overflow (FUNC_NAME); - - offset += c_result; - /* Fall through. */ - } - - case SEEK_SET: - { - if (SCM_LIKELY (scm_is_true (stream->set_position_x))) - result = scm_call_1 (stream->set_position_x, scm_from_off_t (offset)); - else - scm_wrong_type_arg_msg (FUNC_NAME, 0, port, - "seekable R6RS custom binary port"); - - /* Assuming setting the position succeeded. */ - c_result = offset; - break; - } - - default: - /* `SEEK_END' cannot be supported. */ - scm_wrong_type_arg_msg (FUNC_NAME, 0, port, - "R6RS custom binary ports do not " - "support `SEEK_END'"); - } - - return c_result; -} -#undef FUNC_NAME - -static void -custom_binary_port_close (SCM port) -{ - struct custom_binary_port *stream = (void *) SCM_STREAM (port); - - if (scm_is_true (stream->close)) - /* Invoke the `close' thunk. */ - scm_call_0 (stream->close); -} - - - - -/* Custom binary input ports. */ - -static scm_t_port_type *custom_binary_input_port_type = 0; - -static inline SCM -make_custom_binary_input_port (SCM read_proc, SCM get_position_proc, - SCM set_position_proc, SCM close_proc) -{ - struct custom_binary_port *stream; - const unsigned long mode_bits = SCM_RDNG; - - stream = scm_gc_typed_calloc (struct custom_binary_port); - stream->read = read_proc; - stream->write = SCM_BOOL_F; - stream->get_position = get_position_proc; - stream->set_position_x = set_position_proc; - stream->close = close_proc; - - return scm_c_make_port_with_encoding (custom_binary_input_port_type, - mode_bits, - sym_ISO_8859_1, sym_error, - (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, - (SCM id, SCM read_proc, SCM get_position_proc, - SCM set_position_proc, SCM close_proc), - "Return a new custom binary input port whose input is drained " - "by invoking @var{read_proc} and passing it a bytevector, an " - "index where octets should be written, and an octet count.") -#define FUNC_NAME s_scm_make_custom_binary_input_port -{ - SCM_VALIDATE_STRING (1, id); - SCM_VALIDATE_PROC (2, read_proc); - - if (!scm_is_false (get_position_proc)) - SCM_VALIDATE_PROC (3, get_position_proc); - - if (!scm_is_false (set_position_proc)) - SCM_VALIDATE_PROC (4, set_position_proc); - - if (!scm_is_false (close_proc)) - SCM_VALIDATE_PROC (5, close_proc); - - return make_custom_binary_input_port (read_proc, get_position_proc, - set_position_proc, close_proc); -} -#undef FUNC_NAME - - -/* Instantiate the custom binary input port type. */ -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_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); - scm_set_port_close (custom_binary_input_port_type, custom_binary_port_close); -} - - /* Binary input. */ @@ -941,169 +769,35 @@ initialize_bytevector_output_ports (void) -/* Custom binary output ports. */ +/* Custom ports. */ -static scm_t_port_type *custom_binary_output_port_type; - - -static inline SCM -make_custom_binary_output_port (SCM write_proc, SCM get_position_proc, - SCM set_position_proc, SCM close_proc) -{ - struct custom_binary_port *stream; - const unsigned long mode_bits = SCM_WRTNG; - - stream = scm_gc_typed_calloc (struct custom_binary_port); - stream->read = SCM_BOOL_F; - stream->write = write_proc; - stream->get_position = get_position_proc; - stream->set_position_x = set_position_proc; - stream->close = close_proc; - - return scm_c_make_port_with_encoding (custom_binary_output_port_type, - mode_bits, - sym_ISO_8859_1, sym_error, - (scm_t_bits) stream); +SCM scm_make_custom_binary_input_port (SCM id, SCM read_proc, + SCM get_position_proc, + SCM set_position_proc, SCM close_proc) { + return scm_call_5 (scm_c_public_ref ("ice-9 binary-ports", + "make-custom-binary-input-port"), + id, read_proc, get_position_proc, set_position_proc, + close_proc); } -/* 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, - (SCM id, SCM write_proc, SCM get_position_proc, - SCM set_position_proc, SCM close_proc), - "Return a new custom binary output port whose output is drained " - "by invoking @var{write_proc} and passing it a bytevector, an " - "index where octets should be written, and an octet count.") -#define FUNC_NAME s_scm_make_custom_binary_output_port -{ - SCM_VALIDATE_STRING (1, id); - SCM_VALIDATE_PROC (2, write_proc); - - if (!scm_is_false (get_position_proc)) - SCM_VALIDATE_PROC (3, get_position_proc); - - if (!scm_is_false (set_position_proc)) - SCM_VALIDATE_PROC (4, set_position_proc); - - if (!scm_is_false (close_proc)) - SCM_VALIDATE_PROC (5, close_proc); - - return make_custom_binary_output_port (write_proc, get_position_proc, - set_position_proc, close_proc); -} -#undef FUNC_NAME - - -/* Instantiate the custom binary output port type. */ -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_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); - scm_set_port_close (custom_binary_output_port_type, custom_binary_port_close); +SCM scm_make_custom_binary_output_port (SCM id, SCM write_proc, + SCM get_position_proc, + SCM set_position_proc, SCM close_proc) { + return scm_call_5 (scm_c_public_ref ("ice-9 binary-ports", + "make-custom-binary-output-port"), + id, write_proc, get_position_proc, set_position_proc, + close_proc); } - - - -/* Custom binary input_output ports. */ - -static scm_t_port_type *custom_binary_input_output_port_type; - - -static inline SCM -make_custom_binary_input_output_port (SCM read_proc, SCM write_proc, - SCM get_position_proc, - SCM set_position_proc, SCM close_proc) -{ - struct custom_binary_port *stream; - const unsigned long mode_bits = SCM_WRTNG | SCM_RDNG; - - stream = scm_gc_typed_calloc (struct custom_binary_port); - stream->read = read_proc; - stream->write = write_proc; - stream->get_position = get_position_proc; - stream->set_position_x = set_position_proc; - stream->close = close_proc; - - return scm_c_make_port_with_encoding (custom_binary_input_output_port_type, - mode_bits, sym_ISO_8859_1, sym_error, - (scm_t_bits) stream); -} - -SCM_DEFINE (scm_make_custom_binary_input_output_port, - "make-custom-binary-input/output-port", 6, 0, 0, - (SCM id, SCM read_proc, SCM write_proc, SCM get_position_proc, - SCM set_position_proc, SCM close_proc), - "Return a new custom binary input/output port. The port's input\n" - "is drained by invoking @var{read_proc} and passing it a\n" - "bytevector, an index where octets should be written, and an\n" - "octet count. The output is drained by invoking @var{write_proc}\n" - "and passing it a bytevector, an index where octets should be\n" - "written, and an octet count.") -#define FUNC_NAME s_scm_make_custom_binary_input_output_port -{ - SCM_VALIDATE_STRING (1, id); - SCM_VALIDATE_PROC (2, read_proc); - SCM_VALIDATE_PROC (3, write_proc); - - if (!scm_is_false (get_position_proc)) - SCM_VALIDATE_PROC (4, get_position_proc); - - if (!scm_is_false (set_position_proc)) - SCM_VALIDATE_PROC (5, set_position_proc); - - if (!scm_is_false (close_proc)) - SCM_VALIDATE_PROC (6, close_proc); - - return make_custom_binary_input_output_port - (read_proc, write_proc, get_position_proc, set_position_proc, close_proc); -} -#undef FUNC_NAME - - -/* Instantiate the custom binary input_output port type. */ -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_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, - custom_binary_port_random_access_p); - scm_set_port_close (custom_binary_input_output_port_type, - custom_binary_port_close); +SCM scm_make_custom_binary_input_output_port (SCM id, SCM read_proc, + SCM write_proc, + SCM get_position_proc, + SCM set_position_proc, + SCM close_proc) { + return scm_call_6 (scm_c_public_ref ("ice-9 binary-ports", + "make-custom-binary-input/output-port"), + id, read_proc, write_proc, get_position_proc, + set_position_proc, close_proc); } @@ -1234,10 +928,7 @@ 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 (); } diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h index 56a535e8e..7b0c17768 100644 --- a/libguile/r6rs-ports.h +++ b/libguile/r6rs-ports.h @@ -1,7 +1,7 @@ #ifndef SCM_R6RS_PORTS_H #define SCM_R6RS_PORTS_H -/* Copyright 2009-2011,2013,2018-2019 +/* Copyright 2009-2011,2013,2018-2019,2023 Free Software Foundation, Inc. This file is part of Guile. @@ -28,7 +28,6 @@ SCM_API SCM scm_eof_object (void); SCM_API SCM scm_open_bytevector_input_port (SCM, SCM); -SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM); SCM_API SCM scm_get_u8 (SCM); SCM_API SCM scm_lookahead_u8 (SCM); SCM_API SCM scm_get_bytevector_n (SCM, SCM); @@ -38,9 +37,12 @@ SCM_API SCM scm_get_bytevector_all (SCM); SCM_API SCM scm_put_u8 (SCM, SCM); SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM); SCM_API SCM scm_open_bytevector_output_port (SCM); + +SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM); SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM); SCM_API SCM scm_make_custom_binary_input_output_port (SCM, SCM, SCM, SCM, SCM, SCM); + SCM_API SCM scm_get_string_n_x (SCM, SCM, SCM, SCM); SCM_API void scm_init_r6rs_ports (void); diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm index bffd74e14..b7eddc93d 100644 --- a/module/ice-9/binary-ports.scm +++ b/module/ice-9/binary-ports.scm @@ -1,5 +1,5 @@ ;;; binary-ports.scm --- Binary IO on ports -;;; Copyright (C) 2009-2011,2013,2016,2019,2021 Free Software Foundation, Inc. +;;; Copyright (C) 2009-2011,2013,2016,2019,2021,2023 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 @@ -27,9 +27,11 @@ (define-module (ice-9 binary-ports) #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:use-module (ice-9 custom-ports) #:export (eof-object open-bytevector-input-port - make-custom-binary-input-port + open-bytevector-output-port get-u8 lookahead-u8 get-bytevector-n @@ -41,7 +43,7 @@ put-u8 put-bytevector unget-bytevector - open-bytevector-output-port + make-custom-binary-input-port make-custom-binary-output-port make-custom-binary-input/output-port call-with-input-bytevector @@ -71,3 +73,110 @@ bytevector composed of the bytes written into the port is returned." (let ((bv (get-bytevector))) (close-port port) bv)))) + +(define (type-error proc expecting val) + (scm-error 'wrong-type-arg proc "Wrong type (expecting `~S'): ~S" + (list expecting val) (list val))) + +(define (custom-binary-port-read read) + (unless (procedure? read) + (type-error "custom-binary-port-read" "procedure" read)) + (lambda (port bv start count) + (let ((ret (read bv start count))) + (unless (and (exact-integer? ret) (<= 0 ret count)) + (scm-error 'out-of-range "custom-binary-port-read" + "Value out of range: ~S" (list ret) (list ret))) + ret))) + +(define (custom-binary-port-write write) + (unless (procedure? write) + (type-error "custom-binary-port-write" "procedure" write)) + (lambda (port bv start count) + (let ((ret (write bv start count))) + (unless (and (exact-integer? ret) (<= 0 ret count)) + (scm-error 'out-of-range "custom-binary-port-write" + "Value out of range: ~S" (list ret) (list ret))) + ret))) + +(define (custom-binary-port-seek get-position set-position!) + (when get-position + (unless (procedure? get-position) + (type-error "custom-binary-port-seek" "procedure" get-position))) + (when set-position! + (unless (procedure? set-position!) + (type-error "custom-binary-port-seek" "procedure" set-position!))) + + (define (seek port offset whence) + (cond + ((eqv? whence SEEK_CUR) + (unless get-position + (type-error "custom-binary-port-seek" + "R6RS custom binary port with `port-position` support" + port)) + (if (zero? offset) + (get-position) + (seek port (+ (get-position) offset) SEEK_SET))) + ((eqv? whence SEEK_SET) + (unless set-position! + (type-error "custom-binary-port-seek" + "Seekable R6RS custom binary port" + port)) + (set-position! offset) + ;; Assume setting the position succeeds. + offset) + ((eqv? whence SEEK_END) + (error "R6RS custom binary ports do not support `SEEK_END'")))) + seek) + +(define (custom-binary-port-close close) + (match close + (#f (lambda (port) #t)) + ((? procedure?) (lambda (port) (close))) + (_ (type-error "custom-binary-port-close" "procedure" close)))) + +(define (custom-binary-port-random-access? set-position!) + (if set-position! + (lambda (port) #t) + (lambda (port) #f))) + +(define (make-custom-binary-input-port id read get-position set-position! close) + (unless (string? id) + (type-error "make-custom-binary-input-port" "string" id)) + (make-custom-port #:id id + #:read (custom-binary-port-read read) + #:seek (custom-binary-port-seek get-position set-position!) + #:close (custom-binary-port-close close) + #:random-access? + (custom-binary-port-random-access? set-position!) + ;; FIXME: Instead default to current encoding, if + ;; someone reads text from this port. + #:encoding 'ISO-8859-1 #:conversion-strategy 'error)) + +(define (make-custom-binary-output-port id write get-position set-position! + close) + (unless (string? id) + (type-error "make-custom-binary-output-port" "string" id)) + (make-custom-port #:id id + #:write (custom-binary-port-write write) + #:seek (custom-binary-port-seek get-position set-position!) + #:close (custom-binary-port-close close) + #:random-access? + (custom-binary-port-random-access? set-position!) + ;; FIXME: Instead default to current encoding, if + ;; someone reads text from this port. + #:encoding 'ISO-8859-1 #:conversion-strategy 'error)) + +(define (make-custom-binary-input/output-port id read write get-position + set-position! close) + (unless (string? id) + (type-error "make-custom-binary-input/output-port" "string" id)) + (make-custom-port #:id id + #:read (custom-binary-port-read read) + #:write (custom-binary-port-write write) + #:seek (custom-binary-port-seek get-position set-position!) + #:close (custom-binary-port-close close) + #:random-access? + (custom-binary-port-random-access? set-position!) + ;; FIXME: Instead default to current encoding, if + ;; someone reads text from this port. + #:encoding 'ISO-8859-1 #:conversion-strategy 'error))