mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-02 07:40:30 +02:00
Code Activity

Remove print state objects, and ports-with-print-state

Browse source 
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.
This commit is contained in:
Andy Wingo 2025-06-17 08:33:47 +02:00
parent d1b548033c
commit 3cf4ca187c
16 changed files with 181 additions and 425 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/backtrace.c
View file

@ -217,8 +217,6 @@ display_backtrace_body (struct display_backtrace_args *a)
scm_i_pthread_once (&once, scm_i_pthread_once (&once,
init_print_frames_var_and_frame_to_stack_vector_var); init_print_frames_var_and_frame_to_stack_vector_var);
a->port = SCM_COERCE_OUTPORT (a->port);
/* Argument checking and extraction. */ /* Argument checking and extraction. */
SCM_VALIDATE_STACK (1, a->stack); SCM_VALIDATE_STACK (1, a->stack);
SCM_VALIDATE_OPOUTPORT (2, a->port); SCM_VALIDATE_OPOUTPORT (2, a->port);

58
libguile/deprecated.c
View file

@ -29,6 +29,7 @@
#include "keywords.h" #include "keywords.h"
#include "modules.h" #include "modules.h"
#include "numbers.h" #include "numbers.h"
#include "ports.h"
#include "symbols.h" #include "symbols.h"
#include "threads.h" #include "threads.h"
#include "variable.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 void

12
libguile/deprecated.h
View file

@ -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 void scm_c_run_hookn (SCM hook, SCM *argv, size_t nargs);
SCM_DEPRECATED SCM scm_hook_to_list (SCM hook); 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. */ /* Deprecated declarations go here. */
void scm_i_init_deprecated (void); void scm_i_init_deprecated (void);

14
libguile/filesys.c
View file

@ -163,8 +163,6 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0,
{ {
int rv; int rv;
object = SCM_COERCE_OUTPORT (object);
#ifdef HAVE_FCHOWN #ifdef HAVE_FCHOWN
if (scm_is_integer (object) || (SCM_OPFPORTP (object))) if (scm_is_integer (object) || (SCM_OPFPORTP (object)))
{ {
@ -373,8 +371,6 @@ SCM_DEFINE (scm_close, "close", 1, 0, 0,
int rv; int rv;
int fd; int fd;
fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
if (SCM_PORTP (fd_or_port)) if (SCM_PORTP (fd_or_port))
return scm_close_port (fd_or_port); return scm_close_port (fd_or_port);
fd = scm_to_int (fd_or_port); fd = scm_to_int (fd_or_port);
@ -628,7 +624,6 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
} }
else else
{ {
object = SCM_COERCE_OUTPORT (object);
SCM_VALIDATE_OPFPORT (1, object); SCM_VALIDATE_OPFPORT (1, object);
fdes = SCM_FPORT_FDES (object); fdes = SCM_FPORT_FDES (object);
SCM_SYSCALL (rv = fstat_or_fstat64 (fdes, &stat_temp)); 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; int use_buf = 0;
size_t cur; size_t cur;
element = SCM_COERCE_OUTPORT (element);
SCM_ASSERT (SCM_OPFPORTP (element), element, pos, "select"); SCM_ASSERT (SCM_OPFPORTP (element), element, pos, "select");
if (pos == SCM_ARG1) if (pos == SCM_ARG1)
{ {
@ -870,7 +864,7 @@ get_element (fd_set *set, SCM element, SCM list)
} }
else else
{ {
fd = SCM_FPORT_FDES (SCM_COERCE_OUTPORT (element)); fd = SCM_FPORT_FDES (element);
} }
if (FD_ISSET (fd, set)) if (FD_ISSET (fd, set))
list = scm_cons (element, list); list = scm_cons (element, list);
@ -1103,8 +1097,6 @@ SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0,
int fdes; int fdes;
int ivalue; int ivalue;
object = SCM_COERCE_OUTPORT (object);
if (SCM_OPFPORTP (object)) if (SCM_OPFPORTP (object))
fdes = SCM_FPORT_FDES (object); fdes = SCM_FPORT_FDES (object);
else else
@ -1133,8 +1125,6 @@ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0,
{ {
int fdes; int fdes;
object = SCM_COERCE_OUTPORT (object);
if (SCM_OPFPORTP (object)) if (SCM_OPFPORTP (object))
{ {
scm_flush (object); scm_flush (object);
@ -1758,8 +1748,6 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
{ {
int rv; int rv;
object = SCM_COERCE_OUTPORT (object);
#if HAVE_FCHMOD #if HAVE_FCHMOD
if (scm_is_integer (object) || SCM_OPFPORTP (object)) if (scm_is_integer (object) || SCM_OPFPORTP (object))
{ {

5
libguile/fports.c
View file

@ -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. Free Software Foundation, Inc.
This file is part of Guile. 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}.") "Return the revealed count for @var{port}.")
#define FUNC_NAME s_scm_port_revealed #define FUNC_NAME s_scm_port_revealed
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPFPORT (1, port); SCM_VALIDATE_OPFPORT (1, port);
return scm_from_int (scm_revealed_count (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; int r;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPFPORT (1, port); SCM_VALIDATE_OPFPORT (1, port);
r = scm_to_int (rcount); r = scm_to_int (rcount);
@ -555,7 +553,6 @@ SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0,
{ {
int a; int a;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPFPORT (1, port); SCM_VALIDATE_OPFPORT (1, port);
a = scm_to_int (addend); a = scm_to_int (addend);

9
libguile/goops.c
View file

@ -295,13 +295,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return class_procedure; return class_procedure;
case scm_tc7_smob: case scm_tc7_smob:
{ return scm_i_smob_class[SCM_TC2SMOBNUM (SCM_TYP16 (x))];
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 */
}
case scm_tc7_port: case scm_tc7_port:
{ {
scm_t_port_type *ptob = SCM_PORT_TYPE (x); scm_t_port_type *ptob = SCM_PORT_TYPE (x);

10
libguile/ioext.c
View file

@ -85,9 +85,6 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0,
int ans, oldfd, newfd; int ans, oldfd, newfd;
scm_t_fport *fp; scm_t_fport *fp;
old = SCM_COERCE_OUTPORT (old);
new = SCM_COERCE_OUTPORT (new);
SCM_VALIDATE_OPFPORT (1, old); SCM_VALIDATE_OPFPORT (1, old);
SCM_VALIDATE_OPFPORT (2, new); SCM_VALIDATE_OPFPORT (2, new);
oldfd = SCM_FPORT_FDES (old); oldfd = SCM_FPORT_FDES (old);
@ -126,8 +123,6 @@ SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
{ {
int oldfd, newfd, rv; int oldfd, newfd, rv;
fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
if (scm_is_integer (fd_or_port)) if (scm_is_integer (fd_or_port))
oldfd = scm_to_int (fd_or_port); oldfd = scm_to_int (fd_or_port);
else else
@ -190,7 +185,6 @@ SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0,
"not change its revealed count.") "not change its revealed count.")
#define FUNC_NAME s_scm_fileno #define FUNC_NAME s_scm_fileno
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPFPORT (1, port); SCM_VALIDATE_OPFPORT (1, port);
return scm_from_int (SCM_FPORT_FDES (port)); return scm_from_int (SCM_FPORT_FDES (port));
} }
@ -212,8 +206,6 @@ SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
{ {
int rv; int rv;
port = SCM_COERCE_OUTPORT (port);
if (!SCM_OPFPORTP (port)) if (!SCM_OPFPORTP (port))
return SCM_BOOL_F; 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 new_fd;
int rv; int rv;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPFPORT (1, port); SCM_VALIDATE_OPFPORT (1, port);
stream = SCM_FSTREAM (port); stream = SCM_FSTREAM (port);
old_fd = stream->fdes; old_fd = stream->fdes;

29
libguile/ports.c
View file

@ -532,7 +532,6 @@ scm_set_current_output_port (SCM port)
#define FUNC_NAME "set-current-output-port" #define FUNC_NAME "set-current-output-port"
{ {
SCM ooutp = scm_fluid_ref (cur_outport_fluid); SCM ooutp = scm_fluid_ref (cur_outport_fluid);
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port); SCM_VALIDATE_OPOUTPORT (1, port);
scm_fluid_set_x (cur_outport_fluid, port); scm_fluid_set_x (cur_outport_fluid, port);
return ooutp; return ooutp;
@ -544,7 +543,6 @@ scm_set_current_error_port (SCM port)
#define FUNC_NAME "set-current-error-port" #define FUNC_NAME "set-current-error-port"
{ {
SCM oerrp = scm_fluid_ref (cur_errport_fluid); SCM oerrp = scm_fluid_ref (cur_errport_fluid);
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port); SCM_VALIDATE_OPOUTPORT (1, port);
scm_fluid_set_x (cur_errport_fluid, port); scm_fluid_set_x (cur_errport_fluid, port);
return oerrp; return oerrp;
@ -556,7 +554,6 @@ scm_set_current_warning_port (SCM port)
#define FUNC_NAME "set-current-warning-port" #define FUNC_NAME "set-current-warning-port"
{ {
SCM owarnp = scm_fluid_ref (cur_warnport_fluid); SCM owarnp = scm_fluid_ref (cur_warnport_fluid);
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port); SCM_VALIDATE_OPOUTPORT (1, port);
scm_fluid_set_x (cur_warnport_fluid, port); scm_fluid_set_x (cur_warnport_fluid, port);
return owarnp; return owarnp;
@ -568,7 +565,6 @@ scm_set_current_info_port (SCM port)
#define FUNC_NAME "set-current-info-port" #define FUNC_NAME "set-current-info-port"
{ {
SCM oinfop = scm_fluid_ref (cur_infoport_fluid); SCM oinfop = scm_fluid_ref (cur_infoport_fluid);
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port); SCM_VALIDATE_OPOUTPORT (1, port);
scm_fluid_set_x (cur_infoport_fluid, port); scm_fluid_set_x (cur_infoport_fluid, port);
return oinfop; return oinfop;
@ -588,7 +584,6 @@ void
scm_dynwind_current_output_port (SCM port) scm_dynwind_current_output_port (SCM port)
#define FUNC_NAME NULL #define FUNC_NAME NULL
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port); SCM_VALIDATE_OPOUTPORT (1, port);
scm_dynwind_fluid (cur_outport_fluid, port); scm_dynwind_fluid (cur_outport_fluid, port);
} }
@ -598,7 +593,6 @@ void
scm_dynwind_current_error_port (SCM port) scm_dynwind_current_error_port (SCM port)
#define FUNC_NAME NULL #define FUNC_NAME NULL
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port); SCM_VALIDATE_OPOUTPORT (1, port);
scm_dynwind_fluid (cur_errport_fluid, 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]; char modes[4];
modes[0] = '\0'; modes[0] = '\0';
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPPORT (1, port); SCM_VALIDATE_OPPORT (1, port);
if (SCM_CELL_WORD_0 (port) & SCM_RDNG) { if (SCM_CELL_WORD_0 (port) & SCM_RDNG) {
if (SCM_CELL_WORD_0 (port) & SCM_WRTNG) 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?}.") "@code{port?}.")
#define FUNC_NAME s_scm_output_port_p #define FUNC_NAME s_scm_output_port_p
{ {
x = SCM_COERCE_OUTPORT (x);
return scm_from_bool (SCM_OUTPUT_PORT_P (x)); return scm_from_bool (SCM_OUTPUT_PORT_P (x));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -935,7 +927,6 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
"descriptors.") "descriptors.")
#define FUNC_NAME s_scm_close_port #define FUNC_NAME s_scm_close_port
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_PORT (1, port); SCM_VALIDATE_PORT (1, port);
return close_port (port, 1); 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.") "which can close file descriptors.")
#define FUNC_NAME s_scm_close_output_port #define FUNC_NAME s_scm_close_output_port
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OUTPUT_PORT (1, port); SCM_VALIDATE_OUTPUT_PORT (1, port);
scm_close_port (port); scm_close_port (port);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
@ -1397,7 +1387,6 @@ SCM_DEFINE (scm_port_read_wait_fd, "port-read-wait-fd", 1, 0, 0,
{ {
int fd; int fd;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPINPORT (1, port); SCM_VALIDATE_OPINPORT (1, port);
fd = port_read_wait_fd (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; int fd;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port); SCM_VALIDATE_OPOUTPORT (1, port);
fd = port_write_wait_fd (port); fd = port_write_wait_fd (port);
@ -1467,7 +1455,6 @@ SCM_DEFINE (scm_port_poll, "port-poll", 2, 1, 0,
int c_timeout; int c_timeout;
SCM ret; SCM ret;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_PORT (1, port); SCM_VALIDATE_PORT (1, port);
SCM_VALIDATE_STRING (2, events); SCM_VALIDATE_STRING (2, events);
c_timeout = SCM_UNBNDP (timeout) ? -1 : SCM_NUM2INT (3, timeout); 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; size_t read_buf_size, write_buf_size, cur, avail;
SCM saved_read_buf; SCM saved_read_buf;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port); SCM_VALIDATE_OPENPORT (1, port);
pt = SCM_PORT (port); pt = SCM_PORT (port);
ptob = SCM_PORT_TYPE (port); ptob = SCM_PORT_TYPE (port);
@ -2467,10 +2452,7 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
if (SCM_UNBNDP (port)) if (SCM_UNBNDP (port))
port = scm_current_output_port (); port = scm_current_output_port ();
else else
{ SCM_VALIDATE_OPOUTPORT (1, port);
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port);
}
scm_flush (port); scm_flush (port);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -3772,8 +3754,6 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
{ {
int how; int how;
fd_port = SCM_COERCE_OUTPORT (fd_port);
how = scm_to_int (whence); how = scm_to_int (whence);
if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END
#ifdef SEEK_DATA #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)); length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR));
} }
object = SCM_COERCE_OUTPORT (object);
if (scm_is_integer (object)) if (scm_is_integer (object))
{ {
off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length); 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.") "non-programmers.")
#define FUNC_NAME s_scm_port_line #define FUNC_NAME s_scm_port_line
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port); SCM_VALIDATE_OPENPORT (1, port);
return scm_port_position_line (SCM_PORT (port)->position); 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.") "first line of a file is 0.")
#define FUNC_NAME s_scm_set_port_line_x #define FUNC_NAME s_scm_set_port_line_x
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port); SCM_VALIDATE_OPENPORT (1, port);
scm_to_long (line); scm_to_long (line);
scm_port_position_set_line (SCM_PORT (port)->position, 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.)") "what non-programmers will find most natural.)")
#define FUNC_NAME s_scm_port_column #define FUNC_NAME s_scm_port_column
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port); SCM_VALIDATE_OPENPORT (1, port);
return scm_port_position_column (SCM_PORT (port)->position); 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.") "character on a line the column should be 0.")
#define FUNC_NAME s_scm_set_port_column_x #define FUNC_NAME s_scm_set_port_column_x
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port); SCM_VALIDATE_OPENPORT (1, port);
scm_to_int (column); scm_to_int (column);
scm_port_position_set_column (SCM_PORT (port)->position, 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.") "if no filename is associated with the port.")
#define FUNC_NAME s_scm_port_filename #define FUNC_NAME s_scm_port_filename
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port); SCM_VALIDATE_OPENPORT (1, port);
return SCM_FILENAME (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.") "@code{port-filename} and reported in diagnostic output.")
#define FUNC_NAME s_scm_set_port_filename_x #define FUNC_NAME s_scm_set_port_filename_x
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port); SCM_VALIDATE_OPENPORT (1, port);
/* We allow the user to set the filename to whatever he likes. */ /* We allow the user to set the filename to whatever he likes. */
SCM_SET_FILENAME (port, filename); SCM_SET_FILENAME (port, filename);

5
libguile/posix.c
View file

@ -1056,7 +1056,6 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
"underlying @var{port}.") "underlying @var{port}.")
#define FUNC_NAME s_scm_ttyname #define FUNC_NAME s_scm_ttyname
{ {
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPPORT (1, port); SCM_VALIDATE_OPPORT (1, port);
if (!SCM_FPORTP (port)) if (!SCM_FPORTP (port))
return SCM_BOOL_F; return SCM_BOOL_F;
@ -1113,8 +1112,6 @@ SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0,
int fd; int fd;
pid_t pgid; pid_t pgid;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPFPORT (1, port); SCM_VALIDATE_OPFPORT (1, port);
fd = SCM_FPORT_FDES (port); fd = SCM_FPORT_FDES (port);
if ((pgid = tcgetpgrp (fd)) == -1) if ((pgid = tcgetpgrp (fd)) == -1)
@ -1136,8 +1133,6 @@ SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0,
{ {
int fd; int fd;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPFPORT (1, port); SCM_VALIDATE_OPFPORT (1, port);
fd = SCM_FPORT_FDES (port); fd = SCM_FPORT_FDES (port);
if (tcsetpgrp (fd, scm_to_int (pgid)) == -1) if (tcsetpgrp (fd, scm_to_int (pgid)) == -1)

350
libguile/print.c
View file

@ -39,8 +39,10 @@
#include "chars.h" #include "chars.h"
#include "continuations-internal.h" #include "continuations-internal.h"
#include "control.h" #include "control.h"
#include "dynwind.h"
#include "ephemerons.h" #include "ephemerons.h"
#include "eval.h" #include "eval.h"
#include "extensions.h"
#include "finalizers.h" #include "finalizers.h"
#include "filesys.h" #include "filesys.h"
#include "fluids.h" #include "fluids.h"
@ -111,10 +113,6 @@ static const char *iflagnames[] =
SCM_SYMBOL (sym_reader, "reader"); SCM_SYMBOL (sym_reader, "reader");
scm_t_option scm_print_opts[] = { 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, { 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. " "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; " "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} /* {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. /* Detection of circular references.
* *
* Due to other constraints in the implementation, this code has bad * Due to other constraints in the implementation, this code has bad
@ -167,14 +182,6 @@ do \
for (i = 0; i < pstate->top; ++i) \ for (i = 0; i < pstate->top; ++i) \
if (scm_is_eq (PSTATE_STACK_REF (pstate, i), (obj))) \ if (scm_is_eq (PSTATE_STACK_REF (pstate, i), (obj))) \
goto label; \ goto label; \
if (pstate->fancyp) \
{ \
if (pstate->top - pstate->list_offset >= pstate->level) \
{ \
scm_putc ('#', port); \
return; \
} \
} \
PUSH_REF(pstate, obj); \ PUSH_REF(pstate, obj); \
} while(0) } while(0)
@ -186,93 +193,51 @@ do \
} \ } \
while (0) 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 #define PSTATE_SIZE 50L
static SCM static scm_i_pthread_key_t print_state_key;
make_print_state (void) 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_i_pthread_key_create (&print_state_key, NULL);
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 static struct scm_print_state*
scm_make_print_state () get_print_state (void)
{ {
SCM answer = SCM_BOOL_F; scm_i_pthread_once (&print_state_once, init_print_state_key);
return scm_i_pthread_getspecific (print_state_key);
/* 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;
} }
void static void
scm_free_print_state (SCM print_state) push_print_state (SCM port, struct scm_print_state *state,
struct scm_print_state *prev)
{ {
SCM handle; memset (state, 0, sizeof (*state));
scm_print_state *pstate = SCM_PRINT_STATE (print_state); state->prev = prev;
/* Cleanup before returning print state to pool. state->port = port;
* It is better to do it here. Doing it in scm_prin1 state->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED);
* would cost more since that function is called much more state->ceiling = SCM_SIMPLE_VECTOR_LENGTH (state->ref_vect);
* often. scm_i_pthread_setspecific (print_state_key, state);
*/
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);
} }
SCM static struct scm_print_state *
scm_i_port_with_print_state (SCM port, SCM print_state) maybe_push_print_state (SCM port, struct scm_print_state *state)
{ {
if (SCM_UNBNDP (print_state)) struct scm_print_state *prev = get_print_state ();
{ for (struct scm_print_state *walk = prev; walk; walk = walk->prev)
if (SCM_PORT_WITH_PS_P (port)) if (scm_is_eq (walk->port, port))
return port; return walk;
else push_print_state (port, state, prev);
print_state = scm_make_print_state (); return state;
/* port does not need to be coerced since it doesn't have ps */ }
}
else static void
port = SCM_COERCE_OUTPORT (port); pop_print_state (struct scm_print_state *state)
return scm_new_double_smob (scm_tc16_port_with_ps, {
SCM_UNPACK (port), SCM_UNPACK (print_state), 0); scm_i_pthread_setspecific (print_state_key, state->prev);
} }
static void static void
@ -552,15 +517,7 @@ static void iprin1 (SCM exp, SCM port, scm_print_state *pstate);
void void
scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{ {
if (pstate->fancyp iprin1 (exp, port, pstate);
&& 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);
} }
static void static void
@ -569,12 +526,6 @@ print_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t),
{ {
long i; long i;
long last = len - 1; 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) for (i = 0; i < last; ++i)
{ {
scm_iprin1 (ref (v, i), port, pstate); 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; */ /* CHECK_INTS; */
scm_iprin1 (ref (v, i), port, pstate); scm_iprin1 (ref (v, i), port, pstate);
} }
if (cutp)
scm_puts (" ...", port);
scm_putc (')', port); scm_putc (')', port);
} }
@ -610,7 +559,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc3_imm24: case scm_tc3_imm24:
if (SCM_CHARP (exp)) if (SCM_CHARP (exp))
{ {
if (SCM_WRITINGP (pstate)) if (pstate->writingp)
write_character (SCM_CHAR (exp), port); write_character (SCM_CHAR (exp), port);
else else
scm_c_put_char (port, SCM_CHAR (exp)); 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); ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS) 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) if (SCM_UNPACK (print) == 0)
goto print_struct; goto print_struct;
pwps = scm_i_port_with_print_state (port, pstate->handle); scm_call_2 (print, exp, port);
pstate->revealed = 1;
scm_call_2 (print, exp, pwps);
} }
else else
{ {
@ -681,7 +628,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{ {
size_t len = scm_i_string_length (exp); size_t len = scm_i_string_length (exp);
if (SCM_WRITINGP (pstate)) if (pstate->writingp)
write_string (scm_i_string_data (exp), write_string (scm_i_string_data (exp),
scm_i_is_narrow_string (exp), scm_i_is_narrow_string (exp),
len, port); len, port);
@ -820,62 +767,44 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
} }
} }
/* Print states are necessary for circular reference safe printing. static void
* They are also expensive to allocate. Therefore print states are dynwind_pop_state (void *data)
* kept in a pool so that they can be reused. {
*/ scm_print_state *state = data;
pop_print_state (state);
}
/* The PORT argument can also be a print-state/port pair, which will static void
* then be used instead of allocating a new print state. This is dynwind_flip_writingp (void *data)
* useful for continuing a chain of print calls from Scheme. */ {
scm_print_state *state = data;
state->writingp = !state->writingp;
}
void void
scm_prin1 (SCM exp, SCM port, int writingp) scm_prin1 (SCM exp, SCM port, int writingp)
{ {
SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */ scm_print_state fresh_state;
SCM pstate_scm; scm_print_state *state = maybe_push_print_state (port, &fresh_state);
scm_print_state *pstate;
int old_writingp;
/* If PORT is a print-state/port pair, use that. Else create a new scm_dynwind_begin (0);
print-state. */
if (SCM_PORT_WITH_PS_P (port)) if (state == &fresh_state)
{ {
pstate_scm = SCM_PORT_WITH_PS_PS (port); state->writingp = writingp;
port = SCM_PORT_WITH_PS_PORT (port); 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 */ dynwind_flip_writingp (state);
scm_i_pthread_mutex_lock (&print_state_mutex); scm_dynwind_unwind_handler (dynwind_flip_writingp, state,
if (!scm_is_null (print_state_pool)) SCM_F_WIND_EXPLICITLY);
{
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);
} }
pstate = SCM_PRINT_STATE (pstate_scm); scm_iprin1 (exp, port, state);
old_writingp = pstate->writingp;
pstate->writingp = writingp;
scm_iprin1 (exp, port, pstate);
pstate->writingp = old_writingp;
/* Return print state to pool if it has been created above and scm_dynwind_end ();
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);
}
} }
static void 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; long floor = pstate->top - 2;
scm_puts (hdr, port); scm_puts (hdr, port);
/* CHECK_INTS; */ /* CHECK_INTS; */
if (pstate->fancyp)
goto fancy_printing;
/* Run a hare and tortoise so that total time complexity will be /* Run a hare and tortoise so that total time complexity will be
O(depth * N) instead of O(N^2). */ O(depth * N) instead of O(N^2). */
hare = SCM_CDR (exp); hare = SCM_CDR (exp);
@ -1063,21 +989,9 @@ fancy_printing:
exp = SCM_CDR (exp); --n; exp = SCM_CDR (exp); --n;
for (; scm_is_pair (exp); exp = SCM_CDR (exp)) for (; scm_is_pair (exp); exp = SCM_CDR (exp))
{ {
register unsigned long i; for (unsigned long i = 0; i < pstate->top; ++i)
for (i = 0; i < pstate->top; ++i)
if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp)) if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
goto fancy_circref; goto fancy_circref;
if (pstate->fancyp)
{
if (n == 0)
{
scm_puts (" ...", port);
goto skip_tail;
}
else
--n;
}
PUSH_REF(pstate, exp); PUSH_REF(pstate, exp);
++pstate->list_offset; ++pstate->list_offset;
scm_putc (' ', port); scm_putc (' ', port);
@ -1090,7 +1004,6 @@ fancy_printing:
scm_puts (" . ", port); scm_puts (" . ", port);
scm_iprin1 (exp, port, pstate); scm_iprin1 (exp, port, pstate);
} }
skip_tail:
pstate->list_offset -= pstate->top - floor - 2; pstate->list_offset -= pstate->top - floor - 2;
goto end; 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_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); */
SCM SCM
@ -1121,7 +1026,7 @@ scm_write (SCM obj, SCM port)
if (SCM_UNBNDP (port)) if (SCM_UNBNDP (port))
port = scm_current_output_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); scm_prin1 (obj, port, 1);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
@ -1136,7 +1041,7 @@ scm_display (SCM obj, SCM port)
if (SCM_UNBNDP (port)) if (SCM_UNBNDP (port))
port = scm_current_output_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); scm_prin1 (obj, port, 0);
return SCM_UNSPECIFIED; 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)) if (scm_is_eq (destination, SCM_BOOL_T))
{ {
destination = port = scm_current_output_port (); destination = port = scm_current_output_port ();
SCM_VALIDATE_OPORT_VALUE (1, destination); SCM_VALIDATE_OPOUTPORT (1, destination);
} }
else if (scm_is_false (destination)) else if (scm_is_false (destination))
{ {
@ -1176,8 +1081,8 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
} }
else else
{ {
SCM_VALIDATE_OPORT_VALUE (1, destination); SCM_VALIDATE_OPOUTPORT (1, destination);
port = SCM_COERCE_OUTPORT (destination); port = destination;
} }
SCM_VALIDATE_STRING (2, message); SCM_VALIDATE_STRING (2, message);
SCM_VALIDATE_REST_ARGUMENT (args); SCM_VALIDATE_REST_ARGUMENT (args);
@ -1248,9 +1153,9 @@ SCM_DEFINE (scm_newline, "newline", 0, 1, 0,
if (SCM_UNBNDP (port)) if (SCM_UNBNDP (port))
port = scm_current_output_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; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -1262,8 +1167,6 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
{ {
if (SCM_UNBNDP (port)) if (SCM_UNBNDP (port))
port = scm_current_output_port (); port = scm_current_output_port ();
else
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_CHAR (1, chr); SCM_VALIDATE_CHAR (1, chr);
SCM_VALIDATE_OPOUTPORT (2, port); 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 void
scm_init_print () 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" #include "print.x"
scm_init_opts (scm_print_options, scm_print_opts); 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); scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader);
} }

67
libguile/print.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_PRINT_H #ifndef SCM_PRINT_H
#define 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. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -29,63 +29,10 @@
/* State information passed around during printing. struct scm_print_state;
*/ typedef struct scm_print_state scm_print_state;
#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;
SCM_API SCM scm_print_options (SCM setting); 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_intprint (intmax_t n, int radix, SCM port);
SCM_API void scm_uintprint (uintmax_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); 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_simple_format (SCM port, SCM message, SCM args);
SCM_API SCM scm_newline (SCM port); SCM_API SCM scm_newline (SCM port);
SCM_API SCM scm_write_char (SCM chr, 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); SCM_INTERNAL void scm_init_print (void);
#ifdef GUILE_DEBUG
SCM_API SCM scm_current_pstate (void);
#endif
#endif /* SCM_PRINT_H */ #endif /* SCM_PRINT_H */

14
libguile/private-options.h
View file

@ -1,4 +1,4 @@
/* Copyright 2007,2009-2011,2014,2018,2020 /* Copyright 2007,2009-2011,2014,2018,2020,2025
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. 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[]; SCM_INTERNAL scm_t_option scm_print_opts[];
#define SCM_PRINT_HIGHLIGHT_PREFIX_I 0 #define SCM_PRINT_KEYWORD_STYLE_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 (SCM_PACK (scm_print_opts[2].val)) #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_ESCAPE_NEWLINES_P scm_print_opts[1].val
#define SCM_PRINT_R7RS_SYMBOLS_P scm_print_opts[4].val #define SCM_PRINT_R7RS_SYMBOLS_P scm_print_opts[2].val
#define SCM_N_PRINT_OPTIONS 5 #define SCM_N_PRINT_OPTIONS 3
/* /*

5
libguile/promises.c
View file

@ -83,11 +83,8 @@ SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0,
static int static int
promise_print (SCM exp, SCM port, scm_print_state *pstate) promise_print (SCM exp, SCM port, scm_print_state *pstate)
{ {
int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<promise ", port); scm_puts ("#<promise ", port);
SCM_SET_WRITINGP (pstate, 1); scm_write (SCM_PROMISE_DATA (exp), port);
scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
scm_putc ('>', port); scm_putc ('>', port);
return !0; return !0;
} }

12
libguile/socket.c
View file

@ -520,7 +520,6 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
int ioptname; int ioptname;
memset (&optval, 0, optlen); memset (&optval, 0, optlen);
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_OPFPORT (1, sock);
ilevel = scm_to_int (level); ilevel = scm_to_int (level);
ioptname = scm_to_int (optname); ioptname = scm_to_int (optname);
@ -663,8 +662,6 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0,
int ilevel, ioptname; int ilevel, ioptname;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_OPFPORT (1, sock);
ilevel = scm_to_int (level); ilevel = scm_to_int (level);
ioptname = scm_to_int (optname); ioptname = scm_to_int (optname);
@ -759,7 +756,6 @@ SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0,
#define FUNC_NAME s_scm_shutdown #define FUNC_NAME s_scm_shutdown
{ {
int fd; int fd;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock); fd = SCM_FPORT_FDES (sock);
if (shutdown (fd, scm_to_signed_integer (how, 0, 2)) == -1) 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; struct sockaddr *soka;
size_t size; size_t size;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock); fd = SCM_FPORT_FDES (sock);
@ -984,7 +979,6 @@ SCM_DEFINE (scm_bind, "bind", 2, 1, 1,
size_t size; size_t size;
int fd; int fd;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock); fd = SCM_FPORT_FDES (sock);
@ -1022,7 +1016,6 @@ SCM_DEFINE (scm_listen, "listen", 2, 0, 0,
#define FUNC_NAME s_scm_listen #define FUNC_NAME s_scm_listen
{ {
int fd; int fd;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock); fd = SCM_FPORT_FDES (sock);
if (listen (fd, scm_to_int (backlog)) == -1) 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; socklen_t addr_size = MAX_ADDR_SIZE;
scm_t_max_sockaddr addr; scm_t_max_sockaddr addr;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_OPFPORT (1, sock);
c_flags = SCM_UNBNDP (flags) ? 0 : scm_to_int (flags); 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; socklen_t addr_size = MAX_ADDR_SIZE;
scm_t_max_sockaddr addr; scm_t_max_sockaddr addr;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock); fd = SCM_FPORT_FDES (sock);
if (getsockname (fd, (struct sockaddr *) &addr, &addr_size) == -1) 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; socklen_t addr_size = MAX_ADDR_SIZE;
scm_t_max_sockaddr addr; scm_t_max_sockaddr addr;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock); fd = SCM_FPORT_FDES (sock);
if (getpeername (fd, (struct sockaddr *) &addr, &addr_size) == -1) 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; int rv, fd, flg;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_OPFPORT (1, sock);
if (SCM_UNBNDP (flags)) if (SCM_UNBNDP (flags))
@ -1613,7 +1602,6 @@ SCM_DEFINE (scm_sendto, "sendto", 3, 1, 1,
struct sockaddr *soka; struct sockaddr *soka;
size_t size; size_t size;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_FPORT (1, sock); SCM_VALIDATE_FPORT (1, sock);
fd = SCM_FPORT_FDES (sock); fd = SCM_FPORT_FDES (sock);

2
libguile/struct.c
View file

@ -753,7 +753,7 @@ void
scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) scm_print_struct (SCM exp, SCM port, scm_print_state *pstate)
{ {
if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp)))) 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 else
{ {
SCM vtable = SCM_STRUCT_VTABLE (exp); SCM vtable = SCM_STRUCT_VTABLE (exp);

12
module/ice-9/ports.scm
View file

@ -121,8 +121,7 @@
call-with-output-string call-with-output-string
with-output-to-string with-output-to-string
with-error-to-string with-error-to-string
the-eof-object the-eof-object))
inherit-print-state))
(define (replace-bootstrap-bindings syms) (define (replace-bootstrap-bindings syms)
(for-each (for-each
@ -582,7 +581,8 @@ composed of the characters written into the port is returned."
(call-with-output-string (call-with-output-string
(lambda (p) (with-error-to-port p thunk)))) (lambda (p) (with-error-to-port p thunk))))
(define (inherit-print-state old-port new-port) (begin-deprecated
(if (get-print-state old-port) (define-public (inherit-print-state old-port new-port)
(port-with-print-state new-port (get-print-state old-port)) (issue-deprecation-warning
new-port)) "inherit-print-state is deprecated and no longer needed.")
new-port))