diff --git a/am/bootstrap.am b/am/bootstrap.am index ffa37095d..16e632f25 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -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 \ diff --git a/libguile/Makefile.am b/libguile/Makefile.am index eb971fb1c..eed9fd75b 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -347,7 +347,6 @@ DOT_X_FILES = \ vectors.x \ version.x \ vm.x \ - vports.x \ weak-set.x \ weak-table.x \ weak-vector.x diff --git a/libguile/init.c b/libguile/init.c index da3d2f0b7..4022728f9 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -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 */ diff --git a/libguile/vports.c b/libguile/vports.c index 7ec10dd7f..909cc5f48 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -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 #endif -#include -#include -#include -#include - -#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{} #\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); } diff --git a/libguile/vports.h b/libguile/vports.h index 3a8d04e8b..6d5060541 100644 --- a/libguile/vports.h +++ b/libguile/vports.h @@ -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 */ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index dc3537063..381960406 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -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. diff --git a/module/ice-9/soft-ports.scm b/module/ice-9/soft-ports.scm new file mode 100644 index 000000000..1b2b2dc9c --- /dev/null +++ b/module/ice-9/soft-ports.scm @@ -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 +;;; . + +;;; 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{} # +@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))))