mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Rewrite soft ports in Scheme

Browse source 
This also makes soft ports suspendable.

* am/bootstrap.am (SOURCES): Add (ice-9 soft-ports).
* libguile/init.c (scm_i_init_guile): No need to init vports.
* libguile/vports.c: Call out to (ice-9 soft-ports).
* libguile/vports.h: Remove internal scm_init_vports.
* module/ice-9/boot-9.scm (the-scm-module): Import (ice-9 soft-ports).
Really this enlarges the boot closure a bit, so we should probably
refactor.
* module/ice-9/soft-ports.scm: New file.
This commit is contained in:
Andy Wingo 2023-05-28 22:17:37 +02:00
parent bf4e8f911e
commit 5bdc663af9
7 changed files with 225 additions and 217 deletions
Download patch file Download diff file Expand all files Collapse all files

1
am/bootstrap.am
View file

@ -185,6 +185,7 @@ SOURCES = \
ice-9/serialize.scm \
ice-9/session.scm \
ice-9/slib.scm \
ice-9/soft-ports.scm \
ice-9/stack-catch.scm \
ice-9/streams.scm \
ice-9/string-fun.scm \

1
libguile/Makefile.am
View file

@ -347,7 +347,6 @@ DOT_X_FILES = \
vectors.x \
version.x \
vm.x \
vports.x \
weak-set.x \
weak-table.x \
weak-vector.x

2
libguile/init.c
View file

@ -150,7 +150,6 @@
#include "vectors.h"
#include "version.h"
#include "vm.h"
#include "vports.h"
#include "weak-set.h"
#include "weak-table.h"
#include "weak-vector.h"
@ -472,7 +471,6 @@ scm_i_init_guile (void *base)
scm_init_weak_table ();
scm_init_weak_vectors ();
scm_init_guardians (); /* requires smob_prehistory */
scm_init_vports ();
scm_init_standard_ports (); /* Requires fports */
scm_init_expand (); /* Requires structs */
scm_init_memoize (); /* Requires smob_prehistory */

225
libguile/vports.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-1996,1998-2003,2006,2009-2011,2013,2018
/* Copyright 1995-1996,1998-2003,2006,2009-2011,2013,2018,2023
Free Software Foundation, Inc.
This file is part of Guile.
@ -24,227 +24,30 @@
# include <config.h>
#endif
#include <assert.h>
#include <errno.h>
#include <stdio.h>
#include <string.h>
#include "boolean.h"
#include "chars.h"
#include "eval.h"
#include "fports.h"
#include "gsubr.h"
#include "numbers.h"
#include "ports-internal.h"
#include "ports.h"
#include "strings.h"
#include "vectors.h"
#include "modules.h"
#include "threads.h"
#include "variable.h"
#include "vports.h"
/* {Ports - soft ports}
*
*/
static scm_t_port_type *scm_soft_port_type;
#define ENCODE_BUF_SIZE 10
struct soft_port {
SCM write_char;
SCM write_string;
SCM flush;
SCM read_char;
SCM close;
SCM input_waiting;
uint8_t encode_buf[ENCODE_BUF_SIZE];
size_t encode_cur;
size_t encode_end;
};
/* Sadly it seems that most code expects there to be no write buffering
at all. */
static void
soft_port_get_natural_buffer_sizes (SCM port, size_t *read_size,
size_t *write_size)
{
*write_size = 1;
}
static size_t
soft_port_write (SCM port, SCM src, size_t start, size_t count)
{
struct soft_port *stream = (void *) SCM_STREAM (port);
signed char * ptr = SCM_BYTEVECTOR_CONTENTS (src) + start;
scm_call_1 (stream->write_string,
scm_from_port_stringn ((char *) ptr, count, port));
/* Backwards compatibility. */
if (scm_is_true (stream->flush))
scm_call_0 (stream->flush);
return count;
}
/* places a single char in the input buffer. */
static size_t
soft_port_read (SCM port, SCM dst, size_t start, size_t count)
{
size_t written;
struct soft_port *stream = (void *) SCM_STREAM (port);
signed char *dst_ptr = SCM_BYTEVECTOR_CONTENTS (dst) + start;
/* A character can be more than one byte, but we don't have a
guarantee that there is more than one byte in the read buffer. So,
use an intermediate buffer. Terrible. This whole facility should
be (re)designed. */
if (stream->encode_cur == stream->encode_end)
{
SCM ans;
char *str;
size_t len;
ans = scm_call_0 (stream->read_char);
if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
return 0;
SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "soft_port_read");
/* It's possible to make a fast path here, but it would be fastest
if the read procedure could fill its buffer directly. */
str = scm_to_port_stringn (scm_string (scm_list_1 (ans)), &len, port);
assert (len > 0 && len <= ENCODE_BUF_SIZE);
stream->encode_cur = 0;
stream->encode_end = len;
memcpy (stream->encode_buf, str, len);
free (str);
}
for (written = 0;
written < count && stream->encode_cur < stream->encode_end;
written++, stream->encode_cur++)
dst_ptr[written] = stream->encode_buf[stream->encode_cur];
return written;
}
static SCM make_soft_port_var;
static void
soft_port_close (SCM port)
init_make_soft_port_var (void)
{
struct soft_port *stream = (void *) SCM_STREAM (port);
if (scm_is_true (stream->close))
scm_call_0 (stream->close);
make_soft_port_var =
scm_c_public_variable ("ice-9 soft-ports", "make-soft-port");
}
static int
soft_port_input_waiting (SCM port)
SCM
scm_make_soft_port (SCM pv, SCM modes)
{
struct soft_port *stream = (void *) SCM_STREAM (port);
if (scm_is_true (stream->input_waiting))
return scm_to_int (scm_call_0 (stream->input_waiting));
/* Default is such that char-ready? for soft ports returns #t, as it
did before this extension was implemented. */
return 1;
}
SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0,
(SCM pv, SCM modes),
"Return a port capable of receiving or delivering characters as\n"
"specified by the @var{modes} string (@pxref{File Ports,\n"
"open-file}). @var{pv} must be a vector of length 5 or 6. Its\n"
"components are as follows:\n"
"\n"
"@enumerate 0\n"
"@item\n"
"procedure accepting one character for output\n"
"@item\n"
"procedure accepting a string for output\n"
"@item\n"
"thunk for flushing output\n"
"@item\n"
"thunk for getting one character\n"
"@item\n"
"thunk for closing port (not by garbage collection)\n"
"@item\n"
"(if present and not @code{#f}) thunk for computing the number of\n"
"characters that can be read from the port without blocking.\n"
"@end enumerate\n"
"\n"
"For an output-only port only elements 0, 1, 2, and 4 need be\n"
"procedures. For an input-only port only elements 3 and 4 need\n"
"be procedures. Thunks 2 and 4 can instead be @code{#f} if\n"
"there is no useful operation for them to perform.\n"
"\n"
"If thunk 3 returns @code{#f} or an @code{eof-object}\n"
"(@pxref{Input, eof-object?, ,r5rs, The Revised^5 Report on\n"
"Scheme}) it indicates that the port has reached end-of-file.\n"
"For example:\n"
"\n"
"@lisp\n"
"(define stdout (current-output-port))\n"
"(define p (make-soft-port\n"
" (vector\n"
" (lambda (c) (write c stdout))\n"
" (lambda (s) (display s stdout))\n"
" (lambda () (display \".\" stdout))\n"
" (lambda () (char-upcase (read-char)))\n"
" (lambda () (display \"@@\" stdout)))\n"
" \"rw\"))\n"
"\n"
"(write p p) @result{} #<input-output: soft 8081e20>\n"
"@end lisp")
#define FUNC_NAME s_scm_make_soft_port
{
int vlen;
struct soft_port *stream;
SCM_VALIDATE_VECTOR (1, pv);
vlen = SCM_SIMPLE_VECTOR_LENGTH (pv);
SCM_ASSERT ((vlen == 5) || (vlen == 6), pv, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, modes);
stream = scm_gc_typed_calloc (struct soft_port);
stream->write_char = SCM_SIMPLE_VECTOR_REF (pv, 0);
stream->write_string = SCM_SIMPLE_VECTOR_REF (pv, 1);
stream->flush = SCM_SIMPLE_VECTOR_REF (pv, 2);
stream->read_char = SCM_SIMPLE_VECTOR_REF (pv, 3);
stream->close = SCM_SIMPLE_VECTOR_REF (pv, 4);
stream->input_waiting =
vlen == 6 ? SCM_SIMPLE_VECTOR_REF (pv, 5) : SCM_BOOL_F;
return scm_c_make_port (scm_soft_port_type, scm_i_mode_bits (modes),
(scm_t_bits) stream);
}
#undef FUNC_NAME
static scm_t_port_type *
scm_make_sfptob ()
{
scm_t_port_type *ptob = scm_make_port_type ("soft", soft_port_read,
soft_port_write);
scm_set_port_close (ptob, soft_port_close);
scm_set_port_needs_close_on_gc (ptob, 1);
scm_set_port_get_natural_buffer_sizes (ptob,
soft_port_get_natural_buffer_sizes);
scm_set_port_input_waiting (ptob, soft_port_input_waiting);
return ptob;
}
void
scm_init_vports ()
{
scm_soft_port_type = scm_make_sfptob ();
#include "vports.x"
static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
scm_i_pthread_once (&once, init_make_soft_port_var);
return scm_call_2 (scm_variable_ref (make_soft_port_var), pv, modes);
}

3
libguile/vports.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_VPORTS_H
#define SCM_VPORTS_H
/* Copyright 1995-1996,2000,2006,2008,2018
/* Copyright 1995-1996,2000,2006,2008,2018,2023
Free Software Foundation, Inc.
This file is part of Guile.
@ -27,6 +27,5 @@
SCM_API SCM scm_make_soft_port (SCM pv, SCM modes);
SCM_INTERNAL void scm_init_vports (void);
#endif /* SCM_VPORTS_H */

11
module/ice-9/boot-9.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;; Copyright (C) 1995-2014, 2016-2022 Free Software Foundation, Inc.
;;;; Copyright (C) 1995-2014, 2016-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
@ -4700,6 +4700,15 @@ R7RS."
;;; make-soft-port in the default environment. FIXME: we should
;;; figure out how to deprecate this.
;;;
;; FIXME:
(module-use! the-scm-module (resolve-interface '(ice-9 soft-ports)))
;;; A few identifiers that need to be defined in this file are really
;;; internal implementation details. We shove them off into internal
;;; modules, removing them from the (guile) module.

199
module/ice-9/soft-ports.scm Normal file
View file

@ -0,0 +1,199 @@
;;; "Soft" ports
;;; Copyright (C) 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
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;;;
;;; Implementation of legacy soft-port interface.
;;;
;;; Code:
(define-module (ice-9 soft-ports)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 custom-ports)
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (rnrs bytevectors gnu)
#:export (make-soft-port))
(define (type-error proc expecting val)
(scm-error 'wrong-type-arg proc "Wrong type (expecting `~S'): ~S"
(list expecting val) (list val)))
(define (soft-port-read %get-char)
(unless (procedure? %get-char)
(type-error "soft-port-read" "procedure" %get-char))
(define encode-buf-size 10)
(define buffer (make-bytevector encode-buf-size))
(define buffer-pos 0)
(define buffer-len 0)
(define transcoder
(make-custom-binary-output-port
"transcoder"
(lambda (bv start count)
(let ((to-copy (min encode-buf-size count)))
(bytevector-copy! bv start buffer 0 to-copy)
(set! buffer-pos 0)
(set! buffer-len to-copy)
to-copy))
#f #f #f))
(lambda (port bv start count)
(let lp ((start start) (count count) (ret 0))
(unless (< buffer-pos buffer-len)
(match (%get-char)
((or #f (? eof-object?)) ret)
(ch
(unless (eq? (port-encoding port) (port-encoding transcoder))
(set-port-encoding! transcoder (port-encoding port)))
(unless (eq? (port-conversion-strategy port)
(port-conversion-strategy transcoder))
(set-port-conversion-strategy! transcoder
(port-conversion-strategy port)))
(put-char transcoder ch)
(force-output transcoder))))
(let ((to-copy (min count (- buffer-len buffer-pos))))
(bytevector-copy! buffer buffer-pos bv start to-copy)
(set! buffer-pos (+ buffer-pos to-copy))
to-copy))))
(define (soft-port-write %put-string %flush)
(unless (procedure? %put-string)
(type-error "soft-port-write" "procedure" %put-string))
(when %flush
(unless (procedure? %flush)
(type-error "soft-port-write" "procedure" %flush)))
(lambda (port bv start count)
(let* ((bytes (bytevector-slice bv start count))
(str (call-with-input-bytevector
bytes
(lambda (bport)
(set-port-encoding! bport (port-encoding port))
(set-port-conversion-strategy!
bport
(port-conversion-strategy port))
(get-string-all bport)))))
(%put-string str)
(if %flush (%flush))
count)))
(define (soft-port-close %close)
(unless (procedure? %close)
(type-error "soft-port-close" "procedure" %close))
(lambda (port) (%close)))
(define (soft-port-input-waiting? %input-ready)
(unless (procedure? %input-ready)
(type-error "soft-port-close" "procedure" %input-ready))
(lambda (port) (< 0 (%input-ready))))
(define (%make-soft-port %put-char %put-string %flush %get-char %close
%input-ready reading? writing? buffering)
(cond
((not (or reading? writing?))
(%make-void-port ""))
(else
(let ((port
(make-custom-port
#:id "soft-port"
#:read (and reading? (soft-port-read %get-char))
#:write (and writing? (soft-port-write %put-string %flush))
#:seek (lambda (port offset whence)
(error "soft ports are not seekable"))
#:close (if %close
(soft-port-close %close)
(lambda (port) (values)))
#:get-natural-buffer-sizes (lambda (port read-size write-size)
;; The in-practice expectation
;; is that soft ports have
;; unbuffered output.
(values read-size 1))
#:random-access? (lambda (port) #f)
#:input-waiting? (if %input-ready
(soft-port-input-waiting? %input-ready)
(lambda (port) #t))
#:close-on-gc? #t)))
(when buffering
(setvbuf port buffering))
port))))
(define (make-soft-port vtable modes)
"Return a port capable of receiving or delivering characters as
specified by the @var{modes} string (@pxref{File Ports, open-file}).
@var{pv} must be a vector of length 5 or 6. Its components are as
follows:
@enumerate 0
@item
procedure accepting one character for output
@item
procedure accepting a string for output
@item
thunk for flushing output
@item
thunk for getting one character
@item
thunk for closing port (not by garbage collection)
@item
(if present and not @code{#f}) thunk for computing the number of
characters that can be read from the port without blocking. @end
enumerate
For an output-only port only elements 0, 1, 2, and 4 need be procedures.
For an input-only port only elements 3 and 4 need be procedures. Thunks
2 and 4 can instead be @code{#f} if there is no useful operation for
them to perform.
If thunk 3 returns @code{#f} or an @code{eof-object}
(@pxref{Input, eof-object?, ,r5rs, The Revised^5 Report on
Scheme}) it indicates that the port has reached end-of-file.
For example:
@lisp
(define stdout (current-output-port))
(define p (make-soft-port
(vector
(lambda (c) (write c stdout))
(lambda (s) (display s stdout))
(lambda () (display \".\" stdout))
(lambda () (char-upcase (read-char)))
(lambda () (display \"@@\" stdout)))
\"rw\"))
(write p p) @result{} #<input-output: soft 8081e20>
@end lisp"
(define reading?
(or (string-index modes #\r)
(string-index modes #\+)))
(define writing?
(or (string-index modes #\w)
(string-index modes #\a)
(string-index modes #\+)))
(define buffering
(and writing?
(cond
((string-index modes #\0) 'none)
((string-index modes #\l) 'line)
(else #f))))
(match vtable
(#(%put-char %put-string %flush %get-char %close)
(%make-soft-port %put-char %put-string %flush %get-char %close #f
reading? writing? buffering))
(#(%put-char %put-string %flush %get-char %close %chars-waiting)
(%make-soft-port %put-char %put-string %flush %get-char %close
%chars-waiting
reading? writing? buffering))))