[Guile-commits] 04/08: Add "custom ports"

[Andy Wingo]

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

commit 87972164334d8a4c14cbc20f794b2fcf902157ce
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Sat May 27 21:51:57 2023 +0200

    Add "custom ports"
    
    Custom ports are a kind of port that exposes the C port type interface
    directly to Scheme.  In this way the full capability of C is available
    to Scheme, and also the read and write functions can be tail-called from
    Scheme (via port-read / port-write).
    
    * libguile/custom-ports.c:
    * libguile/custom-ports.h:
    * module/ice-9/custom-ports.scm: New files.
    * libguile/init.c:
    * libguile/Makefile.am:
    * am/bootstrap.am: Add to the build.
---
 am/bootstrap.am               |   3 +-
 libguile/Makefile.am          |   8 +-
 libguile/custom-ports.c       | 188 ++++++++++++++++++++++++++++++++++++++++++
 libguile/custom-ports.h       |  29 +++++++
 libguile/init.c               |   4 +-
 module/ice-9/custom-ports.scm | 140 +++++++++++++++++++++++++++++++
 6 files changed, 368 insertions(+), 4 deletions(-)

diff --git a/am/bootstrap.am b/am/bootstrap.am
index 53ee68315..ffa37095d 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -1,4 +1,4 @@
-##     Copyright (C) 2009-2022 Free Software Foundation, Inc.
+##     Copyright (C) 2009-2023 Free Software Foundation, Inc.
 ##
 ##   This file is part of GNU Guile.
 ##
@@ -132,6 +132,7 @@ SOURCES =                                   \
   ice-9/control.scm                            \
   ice-9/copy-tree.scm                          \
   ice-9/curried-definitions.scm                        \
+  ice-9/custom-ports.scm                       \
   ice-9/deprecated.scm                         \
   ice-9/documentation.scm                      \
   ice-9/eval-string.scm                                \
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 36b3ed502..eb971fb1c 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -1,6 +1,6 @@
 ## Process this file with Automake to create Makefile.in
 ##
-##   Copyright (C) 1998-2004, 2006-2014, 2016-2022
+##   Copyright (C) 1998-2004, 2006-2014, 2016-2023
 ##     Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
@@ -139,6 +139,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =             
                \
        chooks.c                                \
        control.c                               \
        continuations.c                         \
+       custom-ports.c                          \
        debug.c                                 \
        deprecated.c                            \
        deprecation.c                           \
@@ -259,6 +260,7 @@ DOT_X_FILES =                                       \
        chars.x                                 \
        control.x                               \
        continuations.x                         \
+       custom-ports.x                          \
        debug.x                                 \
        deprecated.x                            \
        deprecation.x                           \
@@ -366,6 +368,7 @@ DOT_DOC_FILES =                             \
        chars.doc                               \
        control.doc                             \
        continuations.doc                       \
+       custom-ports.doc                        \
        debug.doc                               \
        deprecated.doc                          \
        deprecation.doc                         \
@@ -530,7 +533,8 @@ uninstall-hook:
 ## compile, since they are #included.  So instead we list them here.
 ## Perhaps we can deal with them normally once the merge seems to be
 ## working.
-noinst_HEADERS = elf.h                                         \
+noinst_HEADERS = custom-ports.h                                        \
+                 elf.h                                         \
                  integers.h                                    \
                  intrinsics.h                                  \
                  quicksort.i.c                                  \
diff --git a/libguile/custom-ports.c b/libguile/custom-ports.c
new file mode 100644
index 000000000..7eefa51ae
--- /dev/null
+++ b/libguile/custom-ports.c
@@ -0,0 +1,188 @@
+/* Copyright 2023
+     Free Software Foundation, Inc.
+
+   This file is part of Guile.
+
+   Guile 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.
+
+   Guile 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 Guile.  If not, see
+   <https://www.gnu.org/licenses/>.  */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "boolean.h"
+#include "eval.h"
+#include "extensions.h"
+#include "gsubr.h"
+#include "modules.h"
+#include "numbers.h"
+#include "ports-internal.h"
+#include "syscalls.h"
+#include "values.h"
+#include "variable.h"
+#include "version.h"
+
+#include "custom-ports.h"
+
+
+#define FOR_EACH_METHOD_EXCEPT_READ_WRITE(M) \
+  M(print, "print") \
+  M(read_wait_fd, "read-wait-fd") \
+  M(write_wait_fd, "write-wait-fd") \
+  M(seek, "seek") \
+  M(close, "close") \
+  M(get_natural_buffer_sizes, "get-natural-buffer-sizes") \
+  M(random_access_p, "random-access?") \
+  M(input_waiting, "input-waiting?") \
+  M(truncate, "truncate")
+
+#define FOR_EACH_METHOD(M)             \
+  FOR_EACH_METHOD_EXCEPT_READ_WRITE(M) \
+  M(read, "read") \
+  M(write, "write")
+
+#define DEF_VAR(c_name, scm_name) static SCM c_name##_var;
+FOR_EACH_METHOD(DEF_VAR)
+#undef DEF_VAR
+
+static int custom_port_print (SCM exp, SCM port, scm_print_state *pstate) {
+  SCM data = SCM_PACK (SCM_STREAM (exp));
+  scm_call_3 (scm_variable_ref (print_var), exp, data, port);
+  return 1;
+}
+
+static int custom_port_read_wait_fd (SCM port) {
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  return scm_to_int (scm_call_2 (scm_variable_ref (read_wait_fd_var),
+                                 port, data));
+}
+
+static int custom_port_write_wait_fd (SCM port) {
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  return scm_to_int (scm_call_2 (scm_variable_ref (write_wait_fd_var),
+                                 port, data));
+}
+
+static scm_t_off custom_port_seek (SCM port, scm_t_off offset, int whence) {
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  return scm_to_off_t (scm_call_4 (scm_variable_ref (seek_var), port, data,
+                                   scm_from_off_t (offset),
+                                   scm_from_int (whence)));
+}
+
+static void custom_port_close (SCM port) {
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  scm_call_2 (scm_variable_ref (close_var), port, data);
+}
+
+static void custom_port_get_natural_buffer_sizes (SCM port, size_t *read_size,
+                                                  size_t *write_size) {
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  SCM res = scm_call_4 (scm_variable_ref (get_natural_buffer_sizes_var),
+                        port, data, scm_from_size_t (*read_size),
+                        scm_from_size_t (*write_size));
+  *read_size = scm_to_size_t (scm_c_value_ref (res, 0));
+  *write_size = scm_to_size_t (scm_c_value_ref (res, 1));
+}
+
+static int custom_port_random_access_p (SCM port) {
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  return scm_to_bool (scm_call_2 (scm_variable_ref (random_access_p_var),
+                                  port, data));
+}
+
+static int custom_port_input_waiting (SCM port) {
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  return scm_to_bool (scm_call_2 (scm_variable_ref (input_waiting_var),
+                                  port, data));
+}
+
+static void custom_port_truncate (SCM port, scm_t_off length) {
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  scm_call_3 (scm_variable_ref (truncate_var), port, data,
+              scm_from_off_t (length));
+}
+
+static scm_t_port_type *custom_port_type;
+static scm_t_port_type *custom_port_type_with_close_on_gc;
+
+SCM_DEFINE_STATIC (make_custom_port, "%make-custom-port", 6, 0, 0,
+                   (SCM input_p, SCM output_p, SCM stream, SCM encoding,
+                    SCM conversion_strategy, SCM close_on_gc_p),
+                   "") {
+  long mode_bits = 0;
+  if (scm_is_true (input_p))
+    mode_bits |= SCM_RDNG;
+  if (scm_is_true (output_p))
+    mode_bits |= SCM_WRTNG;
+
+  scm_t_port_type *pt = scm_is_true (close_on_gc_p) ?
+    custom_port_type_with_close_on_gc : custom_port_type;
+
+  return scm_c_make_port_with_encoding (pt, mode_bits, encoding,
+                                        conversion_strategy,
+                                        SCM_UNPACK (stream));
+}
+
+SCM_DEFINE_STATIC (custom_port_data, "%custom-port-data", 1, 0, 0,
+                   (SCM port),
+                   "")
+#define FUNC_NAME s_custom_port_data
+{
+  SCM_ASSERT(SCM_PORT_TYPE (port) == custom_port_type
+             || SCM_PORT_TYPE (port) == custom_port_type_with_close_on_gc,
+             port, SCM_ARG1, "custom port");
+  return SCM_PACK (SCM_STREAM (port));
+}
+#undef FUNC_NAME
+
+static void
+scm_init_custom_ports (void)
+{
+#define RESOLVE_VAR(c_name, scm_name) \
+  c_name##_var = scm_c_lookup ("custom-port-" scm_name);
+  FOR_EACH_METHOD(RESOLVE_VAR);
+#undef RESOlVE_VAR
+
+  custom_port_type = scm_make_port_type ("custom-port", NULL, NULL);
+  custom_port_type_with_close_on_gc =
+    scm_make_port_type ("custom-port", NULL, NULL);
+
+#define INIT_PORT_TYPE(c_name, scm_name)                                \
+  scm_set_port_##c_name (custom_port_type, custom_port_##c_name);       \
+  scm_set_port_##c_name (custom_port_type_with_close_on_gc,             \
+                         custom_port_##c_name);
+  FOR_EACH_METHOD_EXCEPT_READ_WRITE(INIT_PORT_TYPE);
+#undef INIT_PORT_TYPE
+
+  scm_set_port_scm_read (custom_port_type, scm_variable_ref (read_var));
+  scm_set_port_scm_write (custom_port_type, scm_variable_ref (write_var));
+  scm_set_port_scm_read (custom_port_type_with_close_on_gc,
+                         scm_variable_ref (read_var));
+  scm_set_port_scm_write (custom_port_type_with_close_on_gc,
+                          scm_variable_ref (write_var));
+
+  scm_set_port_needs_close_on_gc (custom_port_type_with_close_on_gc, 1);
+
+#include "custom-ports.x"
+}
+
+void
+scm_register_custom_ports (void)
+{
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_custom_ports",
+                           (scm_t_extension_init_func) scm_init_custom_ports,
+                           NULL);
+}
diff --git a/libguile/custom-ports.h b/libguile/custom-ports.h
new file mode 100644
index 000000000..287a87837
--- /dev/null
+++ b/libguile/custom-ports.h
@@ -0,0 +1,29 @@
+#ifndef SCM_CUSTOM_PORTS_H
+#define SCM_CUSTOM_PORTS_H
+
+/* Copyright 2023
+     Free Software Foundation, Inc.
+
+   This file is part of Guile.
+
+   Guile 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.
+
+   Guile 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 Guile.  If not, see
+   <https://www.gnu.org/licenses/>.  */
+
+
+
+#include "libguile/scm.h"
+
+SCM_INTERNAL void scm_register_custom_ports (void);
+
+#endif /* SCM_CUSTOM_PORTS_H */
diff --git a/libguile/init.c b/libguile/init.c
index b0a39e6d4..da3d2f0b7 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-2004,2006,2009-2014,2016-2020
+/* Copyright 1995-2004,2006,2009-2014,2016-2021,2023
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -52,6 +52,7 @@
 #include "chars.h"
 #include "continuations.h"
 #include "control.h"
+#include "custom-ports.h"
 #include "debug.h"
 #ifdef GUILE_DEBUG_MALLOC
 #include "debug-malloc.h"
@@ -373,6 +374,7 @@ scm_i_init_guile (void *base)
   scm_bootstrap_programs ();
   scm_bootstrap_vm ();
   scm_register_atomic ();
+  scm_register_custom_ports ();
   scm_register_fdes_finalizers ();
   scm_register_foreign ();
   scm_register_foreign_object ();
diff --git a/module/ice-9/custom-ports.scm b/module/ice-9/custom-ports.scm
new file mode 100644
index 000000000..7ab56a122
--- /dev/null
+++ b/module/ice-9/custom-ports.scm
@@ -0,0 +1,140 @@
+;;; custom-ports.scm --- Defining new ports in Scheme
+;;; 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:
+;;;
+;;; Code:
+
+(define-module (ice-9 custom-ports)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (srfi srfi-9)
+  #:declarative? #f ; Because of extension.
+  #:export (make-custom-port))
+
+;; Replaced by extension; here just to suppress warnings.
+(define %make-custom-port error)
+(define %custom-port-data error)
+
+(define-record-type <custom-port-data>
+  (make-custom-port-data print read write read-wait-fd write-wait-fd
+                         seek close get-natural-buffer-sizes
+                         random-access? input-waiting? truncate)
+  custom-port-data?
+  (print custom-port-data-print)
+  (read custom-port-data-read)
+  (write custom-port-data-write)
+  (read-wait-fd custom-port-data-read-wait-fd)
+  (write-wait-fd custom-port-data-write-wait-fd)
+  (seek custom-port-data-seek)
+  (close custom-port-data-close)
+  (get-natural-buffer-sizes custom-port-data-get-natural-buffer-sizes)
+  (random-access? custom-port-data-random-access?)
+  (input-waiting? custom-port-data-input-waiting?)
+  (truncate custom-port-data-truncate))
+
+(define-syntax define-custom-port-dispatcher
+  (lambda (stx)
+    (define (prefixed-name prefix suffix)
+      (datum->syntax suffix (symbol-append prefix (syntax->datum suffix))))
+    (syntax-case stx ()
+      ((_ stem arg ...)
+       (with-syntax ((accessor (prefixed-name 'custom-port-data- #'stem))
+                     (dispatcher (prefixed-name 'custom-port- #'stem)))
+         #'(define (dispatcher port data arg ...)
+             ((accessor data) port arg ...)))))))
+
+;; These bindings are captured by the extension.
+(define (custom-port-read port bv start count)
+  ((custom-port-data-read (%custom-port-data port)) port bv start count))
+(define (custom-port-write port bv start count)
+  ((custom-port-data-write (%custom-port-data port)) port bv start count))
+(define-custom-port-dispatcher print out-port)
+(define-custom-port-dispatcher read-wait-fd)
+(define-custom-port-dispatcher write-wait-fd)
+(define-custom-port-dispatcher seek offset whence)
+(define-custom-port-dispatcher close)
+(define-custom-port-dispatcher get-natural-buffer-sizes read-size write-size)
+(define-custom-port-dispatcher random-access?)
+(define-custom-port-dispatcher input-waiting?)
+(define-custom-port-dispatcher truncate length)
+
+
+(eval-when (load)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_custom_ports"))
+
+(define (default-print port out-port)
+  (define mode
+    (cond
+     ((port-closed? port) "closed:")
+     ((input-port? port) (if (output-port? port) "input-output:" "input:"))
+     ((output-port? port) "output:")
+     (else "bogus:")))
+  (put-string out-port "#<")
+  (put-string out-port mode)
+  (put-string out-port "custom-port ")
+  (put-string out-port (number->string (object-address port) 16))
+  (put-string out-port ">"))
+
+(define (default-read-wait-fd port)  -1)
+(define (default-write-wait-fd port) -1)
+
+(define (default-seek port offset whence)
+  (error "custom port did not define a seek method" port))
+
+(define (default-close port) (values))
+
+(define (default-get-natural-buffer-sizes port read-buf-size write-buf-size)
+  (values read-buf-size write-buf-size))
+
+(define (default-random-access? port) #t)
+
+(define (default-input-waiting? port) #t)
+(define (default-truncate port length)
+  (error "custom port did not define a truncate method" port))
+
+(define* (make-custom-port
+          #:key
+          (input? #f)
+          (output? #f)
+          (print default-print)
+          read
+          write
+          (read-wait-fd default-read-wait-fd)
+          (write-wait-fd default-write-wait-fd)
+          (seek default-seek)
+          (close default-close)
+          (get-natural-buffer-sizes default-get-natural-buffer-sizes)
+          (random-access? default-random-access?)
+          (input-waiting? default-input-waiting?)
+          (truncate default-truncate)
+          (encoding (string->symbol (fluid-ref %default-port-encoding)))
+          (conversion-strategy (fluid-ref %default-port-conversion-strategy))
+          (close-on-gc? #f))
+  (define data
+    (make-custom-port-data print read write read-wait-fd write-wait-fd
+                           seek close get-natural-buffer-sizes
+                           random-access? input-waiting? truncate))
+  (unless (or input? output?)
+    (error "Must have at least one open mode (#:input? and #:output?)"))
+  (when (and input? (not read))
+    (error "Missing #:read method for input port"))
+  (when (and output? (not write))
+    (error "Missing #:write method for output port"))
+  (%make-custom-port input? output? data encoding conversion-strategy
+                     close-on-gc?))