From 3cf4ca187ceaf4b680ce8dd17d6820a8d731fe2f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 17 Jun 2025 08:33:47 +0200 Subject: [PATCH] Remove print state objects, and ports-with-print-state The goal was that, as part of a print operation, all nested prints of contained data would be able to use the same parameters (e.g. write or not), and also detect cycles, highlight objects, etc. The mechanism was a heap-allocated data structure. However, given that: 1. Nobody accessed print states from Scheme 2. `write` and `display` should move to Scheme anyway, in order to be suspendable 3. The "fancyp" and "highlight" options were unused 4. A simple stack-allocated data structure with a per-thread key could do the trick just as well, without needing the weird freelist structure 5. Ports-with-print-states were a source of bugs In the end we switch print states to be something completely internal to print.c. There are no more SCM print-state objects, and no more ports-with-print-state. * libguile/print.h: Remove print state from API. * libguile/print.c (struct scm_print_state): Move definition here. (scm_print_opts): Remove "highlight-prefix" and "highlight-suffix" options, as they were not used. (ENTER_NESTED_DATA): Remove "fancyp" case. (init_print_state_key, get_print_state, push_print_state) (maybe_push_print_state, pop_print_state): New facility to manage stack of active print states. (scm_iprin1, print_vector): No more fancyp. (iprin1): Access "writingp" member directly. Don't make ports with print states. (scm_prin1): Manage print state stack. (scm_iprlist): No more fancyp. (scm_valid_oport_value_p): Remove; valid outports are SCM_OPOUTPORTP. * libguile/backtrace.c: * libguile/filesys.c: * libguile/fports.c: * libguile/goops.c: * libguile/ioext.c: * libguile/ports.c: * libguile/posix.c: * libguile/promises.c: * libguile/socket.c: * libguile/struct.c: Remove cases that dealt with ports-with-print-states. * libguile/private-options.h: Remove highlight options. * module/ice-9/ports.scm (inherit-print-state): Deprecate. * libguile/deprecated.c: * libguile/deprecated.h: Add deprecation shims for print states, as far as that is possible. --- libguile/backtrace.c | 2 - libguile/deprecated.c | 58 ++++++ libguile/deprecated.h | 12 ++ libguile/filesys.c | 14 +- libguile/fports.c | 5 +- libguile/goops.c | 9 +- libguile/ioext.c | 10 -- libguile/ports.c | 29 +-- libguile/posix.c | 5 - libguile/print.c | 350 ++++++++++--------------------------- libguile/print.h | 67 +------ libguile/private-options.h | 14 +- libguile/promises.c | 5 +- libguile/socket.c | 12 -- libguile/struct.c | 2 +- module/ice-9/ports.scm | 12 +- 16 files changed, 181 insertions(+), 425 deletions(-) diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 73b80075e..569632ffa 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -217,8 +217,6 @@ display_backtrace_body (struct display_backtrace_args *a) scm_i_pthread_once (&once, init_print_frames_var_and_frame_to_stack_vector_var); - a->port = SCM_COERCE_OUTPORT (a->port); - /* Argument checking and extraction. */ SCM_VALIDATE_STACK (1, a->stack); SCM_VALIDATE_OPOUTPORT (2, a->port); diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 520f72b80..ea932d4e9 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -29,6 +29,7 @@ #include "keywords.h" #include "modules.h" #include "numbers.h" +#include "ports.h" #include "symbols.h" #include "threads.h" #include "variable.h" @@ -583,6 +584,63 @@ scm_hook_to_list (SCM hook) } + + +void +scm_free_print_state (SCM) +{ + scm_c_issue_deprecation_warning ("scm_free_print_state is no longer useful; " + "remove calls to it."); +} + +SCM +scm_coerce_outport (SCM val) +{ + scm_c_issue_deprecation_warning + ("SCM_COERCE_OUTPORT is deprecated; just return the value instead."); + return val; +} + +int +scm_valid_oport_value_p (SCM val) +{ + scm_c_issue_deprecation_warning + ("scm_valid_oport_value_p is deprecated. Use SCM_OPOUTPORTP instead."); + return SCM_OPOUTPORTP (val); +} + +SCM +scm_make_print_state (void) +{ + scm_c_issue_deprecation_warning + ("scm_make_print_state is deprecated. Use a custom writer instead."); + return SCM_BOOL_F; +} + +SCM +scm_port_with_print_state (SCM port, SCM pstate) +{ + scm_c_issue_deprecation_warning + ("scm_port_with_print_state is deprecated. Just use ports."); + return port; +} + +SCM +scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *) +{ + scm_c_issue_deprecation_warning + ("scm_printer_apply is deprecated. Just use scm_call_2."); + return scm_call_2 (proc, exp, port); +} + +SCM +scm_get_print_state (SCM port) +{ + scm_c_issue_deprecation_warning + ("scm_get_print_state is deprecated. Use a custom writer instead."); + return SCM_BOOL_F; +} + void diff --git a/libguile/deprecated.h b/libguile/deprecated.h index aba973695..eaa1340ba 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -97,6 +97,18 @@ SCM_DEPRECATED void scm_c_run_hook (SCM hook, SCM args); SCM_DEPRECATED void scm_c_run_hookn (SCM hook, SCM *argv, size_t nargs); SCM_DEPRECATED SCM scm_hook_to_list (SCM hook); +SCM_DEPRECATED void scm_free_print_state (SCM print_state); + +SCM_DEPRECATED SCM scm_coerce_outport (SCM x); +SCM_DEPRECATED int scm_valid_oport_value_p (SCM val); +SCM_DEPRECATED SCM scm_make_print_state (void); +SCM_DEPRECATED SCM scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *); +SCM_DEPRECATED SCM scm_port_with_print_state (SCM port, SCM pstate); +SCM_DEPRECATED SCM scm_get_print_state (SCM port); + +#define SCM_COERCE_OUTPORT(p) (scm_coerce_outport (p)) +#define SCM_VALIDATE_OPORT_VALUE(pos, port) SCM_VALIDATE_OPOUTPORT(pos, port) + /* Deprecated declarations go here. */ void scm_i_init_deprecated (void); diff --git a/libguile/filesys.c b/libguile/filesys.c index 103c6cceb..43e6b33f1 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -163,8 +163,6 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0, { int rv; - object = SCM_COERCE_OUTPORT (object); - #ifdef HAVE_FCHOWN if (scm_is_integer (object) || (SCM_OPFPORTP (object))) { @@ -373,8 +371,6 @@ SCM_DEFINE (scm_close, "close", 1, 0, 0, int rv; int fd; - fd_or_port = SCM_COERCE_OUTPORT (fd_or_port); - if (SCM_PORTP (fd_or_port)) return scm_close_port (fd_or_port); fd = scm_to_int (fd_or_port); @@ -628,7 +624,6 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0, } else { - object = SCM_COERCE_OUTPORT (object); SCM_VALIDATE_OPFPORT (1, object); fdes = SCM_FPORT_FDES (object); SCM_SYSCALL (rv = fstat_or_fstat64 (fdes, &stat_temp)); @@ -795,7 +790,6 @@ set_element (fd_set *set, SCM *ports_ready, SCM element, int pos) int use_buf = 0; size_t cur; - element = SCM_COERCE_OUTPORT (element); SCM_ASSERT (SCM_OPFPORTP (element), element, pos, "select"); if (pos == SCM_ARG1) { @@ -870,7 +864,7 @@ get_element (fd_set *set, SCM element, SCM list) } else { - fd = SCM_FPORT_FDES (SCM_COERCE_OUTPORT (element)); + fd = SCM_FPORT_FDES (element); } if (FD_ISSET (fd, set)) list = scm_cons (element, list); @@ -1103,8 +1097,6 @@ SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0, int fdes; int ivalue; - object = SCM_COERCE_OUTPORT (object); - if (SCM_OPFPORTP (object)) fdes = SCM_FPORT_FDES (object); else @@ -1133,8 +1125,6 @@ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0, { int fdes; - object = SCM_COERCE_OUTPORT (object); - if (SCM_OPFPORTP (object)) { scm_flush (object); @@ -1758,8 +1748,6 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0, { int rv; - object = SCM_COERCE_OUTPORT (object); - #if HAVE_FCHMOD if (scm_is_integer (object) || SCM_OPFPORTP (object)) { diff --git a/libguile/fports.c b/libguile/fports.c index 51c5b3736..79a48e899 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -1,4 +1,4 @@ -/* Copyright 1995-2004,2006-2015,2017-2020,2022 +/* Copyright 1995-2004,2006-2015,2017-2020,2022,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -521,7 +521,6 @@ SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0, "Return the revealed count for @var{port}.") #define FUNC_NAME s_scm_port_revealed { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPFPORT (1, port); return scm_from_int (scm_revealed_count (port)); } @@ -536,7 +535,6 @@ SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, { int r; - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPFPORT (1, port); r = scm_to_int (rcount); @@ -555,7 +553,6 @@ SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0, { int a; - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPFPORT (1, port); a = scm_to_int (addend); diff --git a/libguile/goops.c b/libguile/goops.c index e21a504e4..c8d504bab 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -295,13 +295,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return class_procedure; case scm_tc7_smob: - { - scm_t_bits type = SCM_TYP16 (x); - if (type != scm_tc16_port_with_ps) - return scm_i_smob_class[SCM_TC2SMOBNUM (type)]; - x = SCM_PORT_WITH_PS_PORT (x); - /* fall through to ports */ - } + return scm_i_smob_class[SCM_TC2SMOBNUM (SCM_TYP16 (x))]; + case scm_tc7_port: { scm_t_port_type *ptob = SCM_PORT_TYPE (x); diff --git a/libguile/ioext.c b/libguile/ioext.c index 9a057c812..e5553575e 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -85,9 +85,6 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, int ans, oldfd, newfd; scm_t_fport *fp; - old = SCM_COERCE_OUTPORT (old); - new = SCM_COERCE_OUTPORT (new); - SCM_VALIDATE_OPFPORT (1, old); SCM_VALIDATE_OPFPORT (2, new); oldfd = SCM_FPORT_FDES (old); @@ -126,8 +123,6 @@ SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0, { int oldfd, newfd, rv; - fd_or_port = SCM_COERCE_OUTPORT (fd_or_port); - if (scm_is_integer (fd_or_port)) oldfd = scm_to_int (fd_or_port); else @@ -190,7 +185,6 @@ SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0, "not change its revealed count.") #define FUNC_NAME s_scm_fileno { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPFPORT (1, port); return scm_from_int (SCM_FPORT_FDES (port)); } @@ -212,8 +206,6 @@ SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0, { int rv; - port = SCM_COERCE_OUTPORT (port); - if (!SCM_OPFPORTP (port)) return SCM_BOOL_F; @@ -260,8 +252,6 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, int new_fd; int rv; - port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_OPFPORT (1, port); stream = SCM_FSTREAM (port); old_fd = stream->fdes; diff --git a/libguile/ports.c b/libguile/ports.c index 54fec74d1..07867dd80 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -532,7 +532,6 @@ scm_set_current_output_port (SCM port) #define FUNC_NAME "set-current-output-port" { SCM ooutp = scm_fluid_ref (cur_outport_fluid); - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPOUTPORT (1, port); scm_fluid_set_x (cur_outport_fluid, port); return ooutp; @@ -544,7 +543,6 @@ scm_set_current_error_port (SCM port) #define FUNC_NAME "set-current-error-port" { SCM oerrp = scm_fluid_ref (cur_errport_fluid); - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPOUTPORT (1, port); scm_fluid_set_x (cur_errport_fluid, port); return oerrp; @@ -556,7 +554,6 @@ scm_set_current_warning_port (SCM port) #define FUNC_NAME "set-current-warning-port" { SCM owarnp = scm_fluid_ref (cur_warnport_fluid); - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPOUTPORT (1, port); scm_fluid_set_x (cur_warnport_fluid, port); return owarnp; @@ -568,7 +565,6 @@ scm_set_current_info_port (SCM port) #define FUNC_NAME "set-current-info-port" { SCM oinfop = scm_fluid_ref (cur_infoport_fluid); - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPOUTPORT (1, port); scm_fluid_set_x (cur_infoport_fluid, port); return oinfop; @@ -588,7 +584,6 @@ void scm_dynwind_current_output_port (SCM port) #define FUNC_NAME NULL { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPOUTPORT (1, port); scm_dynwind_fluid (cur_outport_fluid, port); } @@ -598,7 +593,6 @@ void scm_dynwind_current_error_port (SCM port) #define FUNC_NAME NULL { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPOUTPORT (1, port); scm_dynwind_fluid (cur_errport_fluid, port); } @@ -687,7 +681,6 @@ SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0, char modes[4]; modes[0] = '\0'; - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPPORT (1, port); if (SCM_CELL_WORD_0 (port) & SCM_RDNG) { if (SCM_CELL_WORD_0 (port) & SCM_WRTNG) @@ -870,7 +863,6 @@ SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0, "@code{port?}.") #define FUNC_NAME s_scm_output_port_p { - x = SCM_COERCE_OUTPORT (x); return scm_from_bool (SCM_OUTPUT_PORT_P (x)); } #undef FUNC_NAME @@ -935,7 +927,6 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, "descriptors.") #define FUNC_NAME s_scm_close_port { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_PORT (1, port); return close_port (port, 1); @@ -966,7 +957,6 @@ SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0, "which can close file descriptors.") #define FUNC_NAME s_scm_close_output_port { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OUTPUT_PORT (1, port); scm_close_port (port); return SCM_UNSPECIFIED; @@ -1397,7 +1387,6 @@ SCM_DEFINE (scm_port_read_wait_fd, "port-read-wait-fd", 1, 0, 0, { int fd; - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPINPORT (1, port); fd = port_read_wait_fd (port); @@ -1412,7 +1401,6 @@ SCM_DEFINE (scm_port_write_wait_fd, "port-write-wait-fd", 1, 0, 0, { int fd; - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPOUTPORT (1, port); fd = port_write_wait_fd (port); @@ -1467,7 +1455,6 @@ SCM_DEFINE (scm_port_poll, "port-poll", 2, 1, 0, int c_timeout; SCM ret; - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_PORT (1, port); SCM_VALIDATE_STRING (2, events); c_timeout = SCM_UNBNDP (timeout) ? -1 : SCM_NUM2INT (3, timeout); @@ -2315,8 +2302,6 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, size_t read_buf_size, write_buf_size, cur, avail; SCM saved_read_buf; - port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_OPENPORT (1, port); pt = SCM_PORT (port); ptob = SCM_PORT_TYPE (port); @@ -2467,10 +2452,7 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, if (SCM_UNBNDP (port)) port = scm_current_output_port (); else - { - port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_OPOUTPORT (1, port); - } + SCM_VALIDATE_OPOUTPORT (1, port); scm_flush (port); return SCM_UNSPECIFIED; } @@ -3772,8 +3754,6 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, { int how; - fd_port = SCM_COERCE_OUTPORT (fd_port); - how = scm_to_int (whence); if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END #ifdef SEEK_DATA @@ -3901,7 +3881,6 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR)); } - object = SCM_COERCE_OUTPORT (object); if (scm_is_integer (object)) { off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length); @@ -3955,7 +3934,6 @@ SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0, "non-programmers.") #define FUNC_NAME s_scm_port_line { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); return scm_port_position_line (SCM_PORT (port)->position); } @@ -3967,7 +3945,6 @@ SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0, "first line of a file is 0.") #define FUNC_NAME s_scm_set_port_line_x { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); scm_to_long (line); scm_port_position_set_line (SCM_PORT (port)->position, line); @@ -3987,7 +3964,6 @@ SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0, "what non-programmers will find most natural.)") #define FUNC_NAME s_scm_port_column { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); return scm_port_position_column (SCM_PORT (port)->position); } @@ -3999,7 +3975,6 @@ SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0, "character on a line the column should be 0.") #define FUNC_NAME s_scm_set_port_column_x { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); scm_to_int (column); scm_port_position_set_column (SCM_PORT (port)->position, column); @@ -4013,7 +3988,6 @@ SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0, "if no filename is associated with the port.") #define FUNC_NAME s_scm_port_filename { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); return SCM_FILENAME (port); } @@ -4027,7 +4001,6 @@ SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0, "@code{port-filename} and reported in diagnostic output.") #define FUNC_NAME s_scm_set_port_filename_x { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); /* We allow the user to set the filename to whatever he likes. */ SCM_SET_FILENAME (port, filename); diff --git a/libguile/posix.c b/libguile/posix.c index cbdf9659b..d3f76b545 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1056,7 +1056,6 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0, "underlying @var{port}.") #define FUNC_NAME s_scm_ttyname { - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPPORT (1, port); if (!SCM_FPORTP (port)) return SCM_BOOL_F; @@ -1113,8 +1112,6 @@ SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0, int fd; pid_t pgid; - port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_OPFPORT (1, port); fd = SCM_FPORT_FDES (port); if ((pgid = tcgetpgrp (fd)) == -1) @@ -1136,8 +1133,6 @@ SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0, { int fd; - port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_OPFPORT (1, port); fd = SCM_FPORT_FDES (port); if (tcsetpgrp (fd, scm_to_int (pgid)) == -1) diff --git a/libguile/print.c b/libguile/print.c index 256fd8a2a..729d3de01 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -39,8 +39,10 @@ #include "chars.h" #include "continuations-internal.h" #include "control.h" +#include "dynwind.h" #include "ephemerons.h" #include "eval.h" +#include "extensions.h" #include "finalizers.h" #include "filesys.h" #include "fluids.h" @@ -111,10 +113,6 @@ static const char *iflagnames[] = SCM_SYMBOL (sym_reader, "reader"); scm_t_option scm_print_opts[] = { - { SCM_OPTION_SCM, "highlight-prefix", (scm_t_bits)SCM_BOOL_F_BITS, - "The string to print before highlighted values." }, - { SCM_OPTION_SCM, "highlight-suffix", (scm_t_bits)SCM_BOOL_F_BITS, - "The string to print after highlighted values." }, { SCM_OPTION_SCM, "quote-keywordish-symbols", (scm_t_bits)SCM_BOOL_F_BITS, "How to print symbols that have a colon as their first or last character. " "The value '#f' does not quote the colons; '#t' quotes them; " @@ -145,6 +143,23 @@ SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0, /* {Printing of Scheme Objects} */ +/* State information passed around during printing. + */ +struct scm_print_state +{ + struct scm_print_state *prev; + SCM port; /* The port we are writing to */ + int writingp; /* Writing? */ + size_t level; /* Max level */ + size_t length; /* Max number of objects per level */ + size_t list_offset; + size_t top; /* Top of reference stack */ + size_t ceiling; /* Max size of reference stack */ + SCM ref_vect; /* Stack of references used during + circular reference detection; + a vector. */ +}; + /* Detection of circular references. * * Due to other constraints in the implementation, this code has bad @@ -167,14 +182,6 @@ do \ for (i = 0; i < pstate->top; ++i) \ if (scm_is_eq (PSTATE_STACK_REF (pstate, i), (obj))) \ goto label; \ - if (pstate->fancyp) \ - { \ - if (pstate->top - pstate->list_offset >= pstate->level) \ - { \ - scm_putc ('#', port); \ - return; \ - } \ - } \ PUSH_REF(pstate, obj); \ } while(0) @@ -186,93 +193,51 @@ do \ } \ while (0) -SCM scm_print_state_vtable = SCM_BOOL_F; -static SCM print_state_pool = SCM_EOL; -scm_i_pthread_mutex_t print_state_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; - -#ifdef GUILE_DEBUG /* Used for debugging purposes */ - -SCM_DEFINE (scm_current_pstate, "current-pstate", 0, 0, 0, - (), - "Return the current-pstate -- the car of the\n" - "@code{print_state_pool}. @code{current-pstate} is only\n" - "included in @code{--enable-guile-debug} builds.") -#define FUNC_NAME s_scm_current_pstate -{ - if (!scm_is_null (print_state_pool)) - return SCM_CAR (print_state_pool); - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - -#endif - #define PSTATE_SIZE 50L -static SCM -make_print_state (void) +static scm_i_pthread_key_t print_state_key; +static scm_i_pthread_once_t print_state_once = SCM_I_PTHREAD_ONCE_INIT; + +static void +init_print_state_key (void) { - SCM print_state = scm_make_struct_no_tail (scm_print_state_vtable, SCM_EOL); - scm_print_state *pstate = SCM_PRINT_STATE (print_state); - pstate->handle = print_state; - pstate->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED); - pstate->ceiling = SCM_SIMPLE_VECTOR_LENGTH (pstate->ref_vect); - pstate->highlight_objects = SCM_EOL; - return print_state; + scm_i_pthread_key_create (&print_state_key, NULL); } -SCM -scm_make_print_state () +static struct scm_print_state* +get_print_state (void) { - SCM answer = SCM_BOOL_F; - - /* First try to allocate a print state from the pool */ - scm_i_pthread_mutex_lock (&print_state_mutex); - if (!scm_is_null (print_state_pool)) - { - answer = SCM_CAR (print_state_pool); - print_state_pool = SCM_CDR (print_state_pool); - } - scm_i_pthread_mutex_unlock (&print_state_mutex); - - return scm_is_false (answer) ? make_print_state () : answer; + scm_i_pthread_once (&print_state_once, init_print_state_key); + return scm_i_pthread_getspecific (print_state_key); } -void -scm_free_print_state (SCM print_state) +static void +push_print_state (SCM port, struct scm_print_state *state, + struct scm_print_state *prev) { - SCM handle; - scm_print_state *pstate = SCM_PRINT_STATE (print_state); - /* Cleanup before returning print state to pool. - * It is better to do it here. Doing it in scm_prin1 - * would cost more since that function is called much more - * often. - */ - pstate->fancyp = 0; - pstate->revealed = 0; - pstate->highlight_objects = SCM_EOL; - scm_i_pthread_mutex_lock (&print_state_mutex); - handle = scm_cons (print_state, print_state_pool); - print_state_pool = handle; - scm_i_pthread_mutex_unlock (&print_state_mutex); + memset (state, 0, sizeof (*state)); + state->prev = prev; + state->port = port; + state->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED); + state->ceiling = SCM_SIMPLE_VECTOR_LENGTH (state->ref_vect); + scm_i_pthread_setspecific (print_state_key, state); } -SCM -scm_i_port_with_print_state (SCM port, SCM print_state) +static struct scm_print_state * +maybe_push_print_state (SCM port, struct scm_print_state *state) { - if (SCM_UNBNDP (print_state)) - { - if (SCM_PORT_WITH_PS_P (port)) - return port; - else - print_state = scm_make_print_state (); - /* port does not need to be coerced since it doesn't have ps */ - } - else - port = SCM_COERCE_OUTPORT (port); - return scm_new_double_smob (scm_tc16_port_with_ps, - SCM_UNPACK (port), SCM_UNPACK (print_state), 0); + struct scm_print_state *prev = get_print_state (); + for (struct scm_print_state *walk = prev; walk; walk = walk->prev) + if (scm_is_eq (walk->port, port)) + return walk; + push_print_state (port, state, prev); + return state; +} + +static void +pop_print_state (struct scm_print_state *state) +{ + scm_i_pthread_setspecific (print_state_key, state->prev); } static void @@ -552,15 +517,7 @@ static void iprin1 (SCM exp, SCM port, scm_print_state *pstate); void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) { - if (pstate->fancyp - && scm_is_true (scm_memq (exp, pstate->highlight_objects))) - { - scm_display (SCM_PRINT_HIGHLIGHT_PREFIX, port); - iprin1 (exp, port, pstate); - scm_display (SCM_PRINT_HIGHLIGHT_SUFFIX, port); - } - else - iprin1 (exp, port, pstate); + iprin1 (exp, port, pstate); } static void @@ -569,12 +526,6 @@ print_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t), { long i; long last = len - 1; - int cutp = 0; - if (pstate->fancyp && len > pstate->length) - { - last = pstate->length - 1; - cutp = 1; - } for (i = 0; i < last; ++i) { scm_iprin1 (ref (v, i), port, pstate); @@ -585,8 +536,6 @@ print_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t), /* CHECK_INTS; */ scm_iprin1 (ref (v, i), port, pstate); } - if (cutp) - scm_puts (" ...", port); scm_putc (')', port); } @@ -610,7 +559,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc3_imm24: if (SCM_CHARP (exp)) { - if (SCM_WRITINGP (pstate)) + if (pstate->writingp) write_character (SCM_CHAR (exp), port); else scm_c_put_char (port, SCM_CHAR (exp)); @@ -634,12 +583,10 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) ENTER_NESTED_DATA (pstate, exp, circref); if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS) { - SCM pwps, print = pstate->writingp ? g_write : g_display; + SCM print = pstate->writingp ? g_write : g_display; if (SCM_UNPACK (print) == 0) goto print_struct; - pwps = scm_i_port_with_print_state (port, pstate->handle); - pstate->revealed = 1; - scm_call_2 (print, exp, pwps); + scm_call_2 (print, exp, port); } else { @@ -681,7 +628,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) { size_t len = scm_i_string_length (exp); - if (SCM_WRITINGP (pstate)) + if (pstate->writingp) write_string (scm_i_string_data (exp), scm_i_is_narrow_string (exp), len, port); @@ -820,62 +767,44 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) } } -/* Print states are necessary for circular reference safe printing. - * They are also expensive to allocate. Therefore print states are - * kept in a pool so that they can be reused. - */ +static void +dynwind_pop_state (void *data) +{ + scm_print_state *state = data; + pop_print_state (state); +} -/* The PORT argument can also be a print-state/port pair, which will - * then be used instead of allocating a new print state. This is - * useful for continuing a chain of print calls from Scheme. */ +static void +dynwind_flip_writingp (void *data) +{ + scm_print_state *state = data; + state->writingp = !state->writingp; +} void scm_prin1 (SCM exp, SCM port, int writingp) { - SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */ - SCM pstate_scm; - scm_print_state *pstate; - int old_writingp; + scm_print_state fresh_state; + scm_print_state *state = maybe_push_print_state (port, &fresh_state); - /* If PORT is a print-state/port pair, use that. Else create a new - print-state. */ + scm_dynwind_begin (0); - if (SCM_PORT_WITH_PS_P (port)) + if (state == &fresh_state) { - pstate_scm = SCM_PORT_WITH_PS_PS (port); - port = SCM_PORT_WITH_PS_PORT (port); + state->writingp = writingp; + scm_dynwind_unwind_handler (dynwind_pop_state, state, + SCM_F_WIND_EXPLICITLY); } - else + else if (state->writingp != writingp) { - /* First try to allocate a print state from the pool */ - scm_i_pthread_mutex_lock (&print_state_mutex); - if (!scm_is_null (print_state_pool)) - { - handle = print_state_pool; - print_state_pool = SCM_CDR (print_state_pool); - } - scm_i_pthread_mutex_unlock (&print_state_mutex); - if (scm_is_false (handle)) - handle = scm_list_1 (make_print_state ()); - pstate_scm = SCM_CAR (handle); + dynwind_flip_writingp (state); + scm_dynwind_unwind_handler (dynwind_flip_writingp, state, + SCM_F_WIND_EXPLICITLY); } - pstate = SCM_PRINT_STATE (pstate_scm); - old_writingp = pstate->writingp; - pstate->writingp = writingp; - scm_iprin1 (exp, port, pstate); - pstate->writingp = old_writingp; + scm_iprin1 (exp, port, state); - /* Return print state to pool if it has been created above and - hasn't escaped to Scheme. */ - - if (scm_is_true (handle) && !pstate->revealed) - { - scm_i_pthread_mutex_lock (&print_state_mutex); - SCM_SETCDR (handle, print_state_pool); - print_state_pool = handle; - scm_i_pthread_mutex_unlock (&print_state_mutex); - } + scm_dynwind_end (); } static void @@ -1012,9 +941,6 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) long floor = pstate->top - 2; scm_puts (hdr, port); /* CHECK_INTS; */ - if (pstate->fancyp) - goto fancy_printing; - /* Run a hare and tortoise so that total time complexity will be O(depth * N) instead of O(N^2). */ hare = SCM_CDR (exp); @@ -1063,21 +989,9 @@ fancy_printing: exp = SCM_CDR (exp); --n; for (; scm_is_pair (exp); exp = SCM_CDR (exp)) { - register unsigned long i; - - for (i = 0; i < pstate->top; ++i) + for (unsigned long i = 0; i < pstate->top; ++i) if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp)) goto fancy_circref; - if (pstate->fancyp) - { - if (n == 0) - { - scm_puts (" ...", port); - goto skip_tail; - } - else - --n; - } PUSH_REF(pstate, exp); ++pstate->list_offset; scm_putc (' ', port); @@ -1090,7 +1004,6 @@ fancy_printing: scm_puts (" . ", port); scm_iprin1 (exp, port, pstate); } -skip_tail: pstate->list_offset -= pstate->top - floor - 2; goto end; @@ -1105,14 +1018,6 @@ circref: -int -scm_valid_oport_value_p (SCM val) -{ - return (SCM_OPOUTPORTP (val) - || (SCM_PORT_WITH_PS_P (val) - && SCM_OPOUTPORTP (SCM_PORT_WITH_PS_PORT (val)))); -} - /* SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); */ SCM @@ -1121,7 +1026,7 @@ scm_write (SCM obj, SCM port) if (SCM_UNBNDP (port)) port = scm_current_output_port (); - SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write); + SCM_ASSERT (SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write); scm_prin1 (obj, port, 1); return SCM_UNSPECIFIED; @@ -1136,7 +1041,7 @@ scm_display (SCM obj, SCM port) if (SCM_UNBNDP (port)) port = scm_current_output_port (); - SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display); + SCM_ASSERT (SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display); scm_prin1 (obj, port, 0); return SCM_UNSPECIFIED; @@ -1166,7 +1071,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, if (scm_is_eq (destination, SCM_BOOL_T)) { destination = port = scm_current_output_port (); - SCM_VALIDATE_OPORT_VALUE (1, destination); + SCM_VALIDATE_OPOUTPORT (1, destination); } else if (scm_is_false (destination)) { @@ -1176,8 +1081,8 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, } else { - SCM_VALIDATE_OPORT_VALUE (1, destination); - port = SCM_COERCE_OUTPORT (destination); + SCM_VALIDATE_OPOUTPORT (1, destination); + port = destination; } SCM_VALIDATE_STRING (2, message); SCM_VALIDATE_REST_ARGUMENT (args); @@ -1248,9 +1153,9 @@ SCM_DEFINE (scm_newline, "newline", 0, 1, 0, if (SCM_UNBNDP (port)) port = scm_current_output_port (); - SCM_VALIDATE_OPORT_VALUE (1, port); + SCM_VALIDATE_OPOUTPORT (1, port); - scm_putc ('\n', SCM_COERCE_OUTPORT (port)); + scm_putc ('\n', port); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1262,8 +1167,6 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0, { if (SCM_UNBNDP (port)) port = scm_current_output_port (); - else - port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_CHAR (1, chr); SCM_VALIDATE_OPOUTPORT (2, port); @@ -1276,84 +1179,11 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0, -/* Call back to Scheme code to do the printing of special objects - * (like structs). SCM_PRINTER_APPLY applies PROC to EXP and a smob - * containing PORT and PSTATE. This object can be used as the port for - * display/write etc to continue the current print chain. The REVEALED - * field of PSTATE is set to true to indicate that the print state has - * escaped to Scheme and thus has to be freed by the GC. - */ - -scm_t_bits scm_tc16_port_with_ps; - -/* Print exactly as the port itself would */ - -static int -port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate) -{ - obj = SCM_PORT_WITH_PS_PORT (obj); - return SCM_PORT_TYPE (obj)->print (obj, port, pstate); -} - -SCM -scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate) -{ - pstate->revealed = 1; - return scm_call_2 (proc, exp, - scm_i_port_with_print_state (port, pstate->handle)); -} - -SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 1, 1, 0, - (SCM port, SCM pstate), - "Create a new port which behaves like @var{port}, but with an\n" - "included print state @var{pstate}. @var{pstate} is optional.\n" - "If @var{pstate} isn't supplied and @var{port} already has\n" - "a print state, the old print state is reused.") -#define FUNC_NAME s_scm_port_with_print_state -{ - SCM_VALIDATE_OPORT_VALUE (1, port); - if (!SCM_UNBNDP (pstate)) - SCM_VALIDATE_PRINTSTATE (2, pstate); - return scm_i_port_with_print_state (port, pstate); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0, - (SCM port), - "Return the print state of the port @var{port}. If @var{port}\n" - "has no associated print state, @code{#f} is returned.") -#define FUNC_NAME s_scm_get_print_state -{ - if (SCM_PORT_WITH_PS_P (port)) - return SCM_PORT_WITH_PS_PS (port); - if (SCM_OUTPUT_PORT_P (port)) - return SCM_BOOL_F; - SCM_WRONG_TYPE_ARG (1, port); -} -#undef FUNC_NAME - - - void scm_init_print () { - SCM type; - - type = scm_make_vtable (scm_from_utf8_string (SCM_PRINT_STATE_LAYOUT), - SCM_BOOL_F); - scm_set_struct_vtable_name_x (type, scm_from_utf8_symbol ("print-state")); - scm_print_state_vtable = type; - - /* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */ - scm_tc16_port_with_ps = scm_make_smob_type (0, 0); - scm_set_smob_print (scm_tc16_port_with_ps, port_with_ps_print); - #include "print.x" scm_init_opts (scm_print_options, scm_print_opts); - scm_print_opts[SCM_PRINT_HIGHLIGHT_PREFIX_I].val = - SCM_UNPACK (scm_from_utf8_string ("{")); - scm_print_opts[SCM_PRINT_HIGHLIGHT_SUFFIX_I].val = - SCM_UNPACK (scm_from_utf8_string ("}")); scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader); } diff --git a/libguile/print.h b/libguile/print.h index 587475362..ea65217a2 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -1,7 +1,7 @@ #ifndef SCM_PRINT_H #define SCM_PRINT_H -/* Copyright 1995-1996,1998,2000-2001,2003-2004,2006,2008,2010,2012,2017-2018 +/* Copyright 1995-1996,1998,2000-2001,2003-2004,2006,2008,2010,2012,2017-2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -29,63 +29,10 @@ -/* State information passed around during printing. - */ -#define SCM_PRINT_STATE_P(obj) (SCM_STRUCTP(obj) \ - && (scm_is_eq (SCM_STRUCT_VTABLE(obj), \ - scm_print_state_vtable))) -#define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj)) - -#define RESET_PRINT_STATE(pstate) \ -do { \ - pstate->list_offset = 0; \ - pstate->top = 0; \ -} while (0) - -#define SCM_WRITINGP(pstate) ((pstate)->writingp) -#define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); } - -#define SCM_PORT_WITH_PS_P(p) SCM_TYP16_PREDICATE (scm_tc16_port_with_ps, p) -#define SCM_PORT_WITH_PS_PORT(p) SCM_CELL_OBJECT_1 (p) -#define SCM_PORT_WITH_PS_PS(p) SCM_CELL_OBJECT_2 (p) - -#define SCM_COERCE_OUTPORT(p) \ - (SCM_PORT_WITH_PS_P (p) ? SCM_PORT_WITH_PS_PORT (p) : p) - -#define SCM_VALIDATE_OPORT_VALUE(pos, port) \ - do { \ - SCM_ASSERT (scm_valid_oport_value_p (port), port, pos, FUNC_NAME); \ - } while (0) - -#define SCM_VALIDATE_PRINTSTATE(pos, a) \ - SCM_MAKE_VALIDATE_MSG(pos, a, PRINT_STATE_P, "print-state") - -#define SCM_PRINT_STATE_LAYOUT "pwuwuwuwuwuwpwuwuwuwpwpw" -typedef struct scm_print_state { - SCM handle; /* Struct handle */ - int revealed; /* Has the state escaped to Scheme? */ - unsigned long writingp; /* Writing? */ - unsigned long fancyp; /* Fancy printing? */ - unsigned long level; /* Max level */ - unsigned long length; /* Max number of objects per level */ - SCM hot_ref; /* Hot reference */ - unsigned long list_offset; - unsigned long top; /* Top of reference stack */ - unsigned long ceiling; /* Max size of reference stack */ - SCM ref_vect; /* Stack of references used during - circular reference detection; - a vector. */ - SCM highlight_objects; /* List of objects to be highlighted */ -} scm_print_state; - -SCM_API SCM scm_print_state_vtable; - -SCM_API scm_t_bits scm_tc16_port_with_ps; +struct scm_print_state; +typedef struct scm_print_state scm_print_state; SCM_API SCM scm_print_options (SCM setting); -SCM_API SCM scm_make_print_state (void); -SCM_API void scm_free_print_state (SCM print_state); -SCM_INTERNAL SCM scm_i_port_with_print_state (SCM port, SCM print_state); SCM_API void scm_intprint (intmax_t n, int radix, SCM port); SCM_API void scm_uintprint (uintmax_t n, int radix, SCM port); SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port); @@ -98,14 +45,6 @@ SCM_API SCM scm_display (SCM obj, SCM port); SCM_API SCM scm_simple_format (SCM port, SCM message, SCM args); SCM_API SCM scm_newline (SCM port); SCM_API SCM scm_write_char (SCM chr, SCM port); -SCM_API SCM scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *); -SCM_API SCM scm_port_with_print_state (SCM port, SCM pstate); -SCM_API SCM scm_get_print_state (SCM port); -SCM_API int scm_valid_oport_value_p (SCM val); SCM_INTERNAL void scm_init_print (void); -#ifdef GUILE_DEBUG -SCM_API SCM scm_current_pstate (void); -#endif - #endif /* SCM_PRINT_H */ diff --git a/libguile/private-options.h b/libguile/private-options.h index 31f4c0ee4..451e8f8fb 100644 --- a/libguile/private-options.h +++ b/libguile/private-options.h @@ -1,4 +1,4 @@ -/* Copyright 2007,2009-2011,2014,2018,2020 +/* Copyright 2007,2009-2011,2014,2018,2020,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -40,15 +40,11 @@ SCM_INTERNAL scm_t_option scm_debug_opts[]; */ SCM_INTERNAL scm_t_option scm_print_opts[]; -#define SCM_PRINT_HIGHLIGHT_PREFIX_I 0 -#define SCM_PRINT_HIGHLIGHT_PREFIX (SCM_PACK (scm_print_opts[0].val)) -#define SCM_PRINT_HIGHLIGHT_SUFFIX_I 1 -#define SCM_PRINT_HIGHLIGHT_SUFFIX (SCM_PACK (scm_print_opts[1].val)) -#define SCM_PRINT_KEYWORD_STYLE_I 2 +#define SCM_PRINT_KEYWORD_STYLE_I 0 #define SCM_PRINT_KEYWORD_STYLE (SCM_PACK (scm_print_opts[2].val)) -#define SCM_PRINT_ESCAPE_NEWLINES_P scm_print_opts[3].val -#define SCM_PRINT_R7RS_SYMBOLS_P scm_print_opts[4].val -#define SCM_N_PRINT_OPTIONS 5 +#define SCM_PRINT_ESCAPE_NEWLINES_P scm_print_opts[1].val +#define SCM_PRINT_R7RS_SYMBOLS_P scm_print_opts[2].val +#define SCM_N_PRINT_OPTIONS 3 /* diff --git a/libguile/promises.c b/libguile/promises.c index 415842570..8502728c3 100644 --- a/libguile/promises.c +++ b/libguile/promises.c @@ -83,11 +83,8 @@ SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0, static int promise_print (SCM exp, SCM port, scm_print_state *pstate) { - int writingp = SCM_WRITINGP (pstate); scm_puts ("#', port); return !0; } diff --git a/libguile/socket.c b/libguile/socket.c index aa012c919..1e6b42970 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -520,7 +520,6 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, int ioptname; memset (&optval, 0, optlen); - sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); ilevel = scm_to_int (level); ioptname = scm_to_int (optname); @@ -663,8 +662,6 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0, int ilevel, ioptname; - sock = SCM_COERCE_OUTPORT (sock); - SCM_VALIDATE_OPFPORT (1, sock); ilevel = scm_to_int (level); ioptname = scm_to_int (optname); @@ -759,7 +756,6 @@ SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0, #define FUNC_NAME s_scm_shutdown { int fd; - sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); fd = SCM_FPORT_FDES (sock); if (shutdown (fd, scm_to_signed_integer (how, 0, 2)) == -1) @@ -913,7 +909,6 @@ SCM_DEFINE (scm_connect, "connect", 2, 1, 1, struct sockaddr *soka; size_t size; - sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); fd = SCM_FPORT_FDES (sock); @@ -984,7 +979,6 @@ SCM_DEFINE (scm_bind, "bind", 2, 1, 1, size_t size; int fd; - sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); fd = SCM_FPORT_FDES (sock); @@ -1022,7 +1016,6 @@ SCM_DEFINE (scm_listen, "listen", 2, 0, 0, #define FUNC_NAME s_scm_listen { int fd; - sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); fd = SCM_FPORT_FDES (sock); if (listen (fd, scm_to_int (backlog)) == -1) @@ -1336,7 +1329,6 @@ SCM_DEFINE (scm_accept4, "accept", 1, 1, 0, socklen_t addr_size = MAX_ADDR_SIZE; scm_t_max_sockaddr addr; - sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); c_flags = SCM_UNBNDP (flags) ? 0 : scm_to_int (flags); @@ -1373,7 +1365,6 @@ SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0, socklen_t addr_size = MAX_ADDR_SIZE; scm_t_max_sockaddr addr; - sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); fd = SCM_FPORT_FDES (sock); if (getsockname (fd, (struct sockaddr *) &addr, &addr_size) == -1) @@ -1395,7 +1386,6 @@ SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0, socklen_t addr_size = MAX_ADDR_SIZE; scm_t_max_sockaddr addr; - sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); fd = SCM_FPORT_FDES (sock); if (getpeername (fd, (struct sockaddr *) &addr, &addr_size) == -1) @@ -1471,7 +1461,6 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, { int rv, fd, flg; - sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); if (SCM_UNBNDP (flags)) @@ -1613,7 +1602,6 @@ SCM_DEFINE (scm_sendto, "sendto", 3, 1, 1, struct sockaddr *soka; size_t size; - sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_FPORT (1, sock); fd = SCM_FPORT_FDES (sock); diff --git a/libguile/struct.c b/libguile/struct.c index 82329ec76..cdbe8f47f 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -753,7 +753,7 @@ void scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) { if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp)))) - scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate); + scm_call_2 (SCM_STRUCT_PRINTER (exp), exp, port); else { SCM vtable = SCM_STRUCT_VTABLE (exp); diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index e1a6212eb..4eeccfb1c 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -121,8 +121,7 @@ call-with-output-string with-output-to-string with-error-to-string - the-eof-object - inherit-print-state)) + the-eof-object)) (define (replace-bootstrap-bindings syms) (for-each @@ -582,7 +581,8 @@ composed of the characters written into the port is returned." (call-with-output-string (lambda (p) (with-error-to-port p thunk)))) -(define (inherit-print-state old-port new-port) - (if (get-print-state old-port) - (port-with-print-state new-port (get-print-state old-port)) - new-port)) +(begin-deprecated + (define-public (inherit-print-state old-port new-port) + (issue-deprecation-warning + "inherit-print-state is deprecated and no longer needed.") + new-port))