diff options
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/Makefile.am | 8 | ||||
-rw-r--r-- | libguile/custom-ports.c | 205 | ||||
-rw-r--r-- | libguile/custom-ports.h | 29 | ||||
-rw-r--r-- | libguile/init.c | 4 |
4 files changed, 243 insertions, 3 deletions
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..6e2b2ea99 --- /dev/null +++ b/libguile/custom-ports.c @@ -0,0 +1,205 @@ +/* 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)); + SCM res = scm_call_2 (scm_variable_ref (read_wait_fd_var), port, data); + return scm_is_false (res) ? -1 : scm_to_signed_integer (res, 0, INT_MAX); +} + +static int +custom_port_write_wait_fd (SCM port) +{ + SCM data = SCM_PACK (SCM_STREAM (port)); + SCM res = scm_call_2 (scm_variable_ref (write_wait_fd_var), port, data); + return scm_is_false (res) ? -1 : scm_to_signed_integer (res, 0, INT_MAX); +} + +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 (); |