[Guile-commits] 08/08: Rewrite soft ports in Scheme

[Andy Wingo]

wingo pushed a commit to branch wip-custom-ports
in repository guile.

commit 9df5a8dfbaf4994f347a0ad2f9e4a72e0ceff540
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Sun May 28 22:17:37 2023 +0200

    Rewrite soft ports in Scheme
    
    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.
---
 am/bootstrap.am             |   1 +
 libguile/Makefile.am        |   1 -
 libguile/init.c             |   2 -
 libguile/vports.c           | 223 +++-----------------------------------------
 libguile/vports.h           |   3 +-
 module/ice-9/boot-9.scm     |  11 ++-
 module/ice-9/soft-ports.scm | 205 ++++++++++++++++++++++++++++++++++++++++
 7 files changed, 230 insertions(+), 216 deletions(-)

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 <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);
-}
-
-
-static int 
-soft_port_input_waiting (SCM port)
-{
-  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;
+  make_soft_port_var =
+    scm_c_public_variable ("ice-9 soft-ports", "make-soft-port");
 }
 
-void
-scm_init_vports ()
+SCM
+scm_make_soft_port (SCM pv, SCM modes)
 {
-  scm_soft_port_type = scm_make_sfptob ();
+  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+  scm_i_pthread_once (&once, init_make_soft_port_var);
 
-#include "vports.x"
+  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..61d5ffd4d
--- /dev/null
+++ b/module/ice-9/soft-ports.scm
@@ -0,0 +1,205 @@
+;;; "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)
+  #: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 (subbytevector bv start count)
+  (if (and (zero? start) (= count (bytevector-length bv)))
+      bv
+      (let ((sub (make-bytevector count)))
+        (bytevector-copy! bv start sub 0 count)
+        sub)))
+
+(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 (subbytevector 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
+            #:input? reading? #:output? writing?
+            #: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))))