mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 23:00:22 +02:00
Code Activity

* print.h (SCM_PRINT_STATE_P, SCM_COERCE_OPORT): New macros.

Browse source 
(struct scm_print_state) [revealed]: New field.
(scm_print_state_vtable): Make visible to the outside world for
type checking purposes.
(scm_valid_oport_value_p): New prototype.

* print.c (scm_valid_oport_value_p): New function to check whether
a certain value is acceptable as a port argument.
(scm_print_state_vtable): New variable.
(scm_free_print_state): Set `revealed' field to false.
(scm_iprin1): Call user supplied closure printer with
scm_printer_apply.  Print in the traditional way when there isn't
one or when it returns #f.
(scm_prin1, scm_display, scm_write, scm_newline, scm_write_char):
Accept a port/print-state pair in addition to just a port.
(scm_prin1): Don't return the print_state to the pool when it has
been `revealed'.
(scm_printer_apply): Set `revealed' field of print_state to true.
(scm_init_print): Set scm_print_state_vtable.
(print_state_fluid, print_state_fluid_num): Removed.
This commit is contained in:
Marius Vollmer 1997-10-02 14:55:02 +00:00
parent c68296f8fd
commit bb35f3151b
2 changed files with 123 additions and 123 deletions
Download patch file Download diff file Expand all files Collapse all files

231
libguile/print.c
View file

@ -53,7 +53,6 @@
#include "unif.h" #include "unif.h"
#include "alist.h" #include "alist.h"
#include "struct.h" #include "struct.h"
#include "fluids.h"
#include "print.h" #include "print.h"
@ -156,19 +155,10 @@ scm_print_options (setting)
#define EXIT_NESTED_DATA(pstate) { --pstate->top; } #define EXIT_NESTED_DATA(pstate) { --pstate->top; }
SCM scm_print_state_vtable;
static SCM print_state_pool; static SCM print_state_pool;
/* This fluid is an implicit parameter to scm_iprin (and thus
scm_display and scm_write) and carries the current print_state when
Scheme code is called to do some printing. That way, circular
references are detected even when they reach across calls to `display'
or `write'.
The fluid is not visible to Scheme code, but maybe it should. */
static SCM print_state_fluid;
static int print_state_fluid_num;
#ifdef GUILE_DEBUG /* Used for debugging purposes */ #ifdef GUILE_DEBUG /* Used for debugging purposes */
SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate); SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate);
@ -227,6 +217,7 @@ scm_free_print_state (print_state)
* often. * often.
*/ */
pstate->fancyp = 0; pstate->fancyp = 0;
pstate->revealed = 0;
SCM_NEWCELL (handle); SCM_NEWCELL (handle);
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SETCAR (handle, print_state); SCM_SETCAR (handle, print_state);
@ -353,72 +344,65 @@ taloop:
case scm_tcs_closures: case scm_tcs_closures:
/* The user supplied print closure procedure must handle /* The user supplied print closure procedure must handle
macro closures as well. */ macro closures as well. */
if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))) if (SCM_FALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))
{ || SCM_FALSEP (scm_printer_apply (SCM_PRINT_CLOSURE,
SCM ans = scm_cons2 (exp, port, exp, port, pstate)));
scm_cons (SCM_WRITINGP (pstate) {
? SCM_BOOL_T SCM name, code;
: SCM_BOOL_F, if (SCM_TYP16 (exp) == scm_tc16_macro)
SCM_EOL)); {
ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL); /* Printing a macro. */
} prinmacro:
else name = scm_macro_name (exp);
{ if (!SCM_CLOSUREP (SCM_CDR (exp)))
SCM name, code; {
if (SCM_TYP16 (exp) == scm_tc16_macro) code = 0;
{ scm_gen_puts (scm_regular_string, "#<primitive-",
/* Printing a macro. */ port);
prinmacro: }
name = scm_macro_name (exp); else
if (!SCM_CLOSUREP (SCM_CDR (exp))) {
{ code = SCM_CODE (SCM_CDR (exp));
code = 0; scm_gen_puts (scm_regular_string, "#<", port);
scm_gen_puts (scm_regular_string, "#<primitive-", }
port); if (SCM_CAR (exp) & (3L << 16))
} scm_gen_puts (scm_regular_string, "macro", port);
else else
{ scm_gen_puts (scm_regular_string, "syntax", port);
code = SCM_CODE (SCM_CDR (exp)); if (SCM_CAR (exp) & (2L << 16))
scm_gen_puts (scm_regular_string, "#<", port); scm_gen_putc ('!', port);
} }
if (SCM_CAR (exp) & (3L << 16)) else
scm_gen_puts (scm_regular_string, "macro", port); {
else /* Printing a closure. */
scm_gen_puts (scm_regular_string, "syntax", port); name = scm_procedure_name (exp);
if (SCM_CAR (exp) & (2L << 16)) code = SCM_CODE (exp);
scm_gen_putc ('!', port); scm_gen_puts (scm_regular_string, "#<procedure",
} port);
else }
{ if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
/* Printing a closure. */ {
name = scm_procedure_name (exp); scm_gen_putc (' ', port);
code = SCM_CODE (exp); scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
scm_gen_puts (scm_regular_string, "#<procedure", }
port); if (code)
} {
if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) scm_gen_putc (' ', port);
{ scm_iprin1 (SCM_CAR (code), port, pstate);
scm_gen_putc (' ', port); }
scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port); if (code && SCM_PRINT_SOURCE_P)
} {
if (code) code = scm_unmemocopy (SCM_CDR (code),
{ SCM_EXTEND_ENV (SCM_CAR (code),
scm_gen_putc (' ', port); SCM_EOL,
scm_iprin1 (SCM_CAR (code), port, pstate); SCM_ENV (exp)));
} ENTER_NESTED_DATA (pstate, exp, circref);
if (code && SCM_PRINT_SOURCE_P) scm_iprlist (" ", code, '>', port, pstate);
{ EXIT_NESTED_DATA (pstate);
code = scm_unmemocopy (SCM_CDR (code), }
SCM_EXTEND_ENV (SCM_CAR (code), else
SCM_EOL, scm_gen_putc ('>', port);
SCM_ENV (exp))); }
ENTER_NESTED_DATA (pstate, exp, circref);
scm_iprlist (" ", code, '>', port, pstate);
EXIT_NESTED_DATA (pstate);
}
else
scm_gen_putc ('>', port);
}
break; break;
case scm_tc7_mb_string: case scm_tc7_mb_string:
case scm_tc7_mb_substring: case scm_tc7_mb_substring:
@ -638,6 +622,10 @@ taloop:
* kept in a pool so that they can be reused. * kept in a pool so that they can be reused.
*/ */
/* 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. */
void void
scm_prin1 (exp, port, writingp) scm_prin1 (exp, port, writingp)
SCM exp; SCM exp;
@ -648,11 +636,15 @@ scm_prin1 (exp, port, writingp)
SCM pstate_scm; SCM pstate_scm;
scm_print_state *pstate; scm_print_state *pstate;
/* If there is currently a print state active, use that. Else /* If PORT is a print-state/port pair, use that. Else create a new
create a new one. */ print-state. */
pstate_scm = SCM_FAST_FLUID_REF (print_state_fluid_num); if (SCM_NIMP (port) && SCM_CONSP (port))
if (pstate_scm == SCM_BOOL_F) {
pstate_scm = SCM_CDR (port);
port = SCM_CAR (port);
}
else
{ {
/* First try to allocate a print state from the pool */ /* First try to allocate a print state from the pool */
SCM_DEFER_INTS; SCM_DEFER_INTS;
@ -671,8 +663,10 @@ scm_prin1 (exp, port, writingp)
pstate->writingp = writingp; pstate->writingp = writingp;
scm_iprin1 (exp, port, pstate); scm_iprin1 (exp, port, pstate);
/* Return print state to pool, if it has been created above. */ /* Return print state to pool if it has been created above and
if (handle != SCM_BOOL_F) hasn't escaped to Scheme. */
if (handle != SCM_BOOL_F && !pstate->revealed)
{ {
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SETCDR (handle, SCM_CDR (print_state_pool)); SCM_SETCDR (handle, SCM_CDR (print_state_pool));
@ -830,6 +824,15 @@ circref:
int
scm_valid_oport_value_p (SCM val)
{
return SCM_NIMP (val) &&
(SCM_OPOUTPORTP (val) || (SCM_CONSP (val) && SCM_NIMP (SCM_CAR (val)) &&
SCM_OPOUTPORTP (SCM_CAR (val)) &&
SCM_PRINT_STATE_P (SCM_CDR (val))));
}
SCM_PROC(s_write, "write", 1, 1, 0, scm_write); SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
SCM SCM
@ -840,7 +843,8 @@ scm_write (obj, port)
if (SCM_UNBNDP (port)) if (SCM_UNBNDP (port))
port = scm_cur_outp; port = scm_cur_outp;
else else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write); SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
scm_prin1 (obj, port, 1); scm_prin1 (obj, port, 1);
#ifdef HAVE_PIPE #ifdef HAVE_PIPE
# ifdef EPIPE # ifdef EPIPE
@ -862,7 +866,8 @@ scm_display (obj, port)
if (SCM_UNBNDP (port)) if (SCM_UNBNDP (port))
port = scm_cur_outp; port = scm_cur_outp;
else else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display); SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
scm_prin1 (obj, port, 0); scm_prin1 (obj, port, 0);
#ifdef HAVE_PIPE #ifdef HAVE_PIPE
# ifdef EPIPE # ifdef EPIPE
@ -880,10 +885,11 @@ scm_newline (port)
SCM port; SCM port;
{ {
if (SCM_UNBNDP (port)) if (SCM_UNBNDP (port))
port = scm_cur_outp; port = scm_cur_outp;
else else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline); SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG1, s_newline);
scm_gen_putc ('\n', port);
scm_gen_putc ('\n', SCM_COERCE_OPORT (port));
#ifdef HAVE_PIPE #ifdef HAVE_PIPE
# ifdef EPIPE # ifdef EPIPE
if (EPIPE == errno) if (EPIPE == errno)
@ -904,11 +910,12 @@ scm_write_char (chr, port)
SCM port; SCM port;
{ {
if (SCM_UNBNDP (port)) if (SCM_UNBNDP (port))
port = scm_cur_outp; port = scm_cur_outp;
else else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char); SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write_char);
SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char); SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
scm_gen_putc ((int) SCM_ICHR (chr), port); scm_gen_putc ((int) SCM_ICHR (chr), SCM_COERCE_OPORT (port));
#ifdef HAVE_PIPE #ifdef HAVE_PIPE
# ifdef EPIPE # ifdef EPIPE
if (EPIPE == errno) if (EPIPE == errno)
@ -920,39 +927,23 @@ scm_write_char (chr, port)
/* Routines for calling back to Scheme code to do the printing of /* Call back to Scheme code to do the printing of special objects
special objects (like structs). SCM_PRINTER_APPLY applies PROC to EXP (like structs). SCM_PRINTER_APPLY applies PROC to EXP and a pair
and PORT while the print_state_fluid is set to PSTATE. When PROC containing PORT and PSTATE. This pair can be used as the port for
inturn calls `display' or `write', this print_state is picked up and display/write etc to continue the current print chain. The REVEALED
used to control the printing. */ 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. */
struct apply_data {
SCM proc;
SCM arg1;
SCM args;
};
static SCM
apply_stub (void *data)
{
struct apply_data *cl = (struct apply_data *)data;
return scm_apply (cl->proc, cl->arg1, cl->args);
}
SCM SCM
scm_printer_apply (proc, exp, port, pstate) scm_printer_apply (proc, exp, port, pstate)
SCM proc, exp, port; SCM proc, exp, port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
struct apply_data cl; SCM pair = scm_cons (port, pstate->handle);
cl.proc = proc; pstate->revealed = 1;
cl.arg1 = exp; return scm_apply (proc, exp, scm_cons (pair, scm_listofnull));
cl.args = scm_cons (port, scm_listofnull);
return scm_internal_with_fluids (scm_cons (print_state_fluid, SCM_EOL),
scm_cons (pstate->handle, SCM_EOL),
apply_stub, (void *)&cl);
} }
void void
@ -968,9 +959,7 @@ scm_init_print ()
SCM_EOL)); SCM_EOL));
print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL)); print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL));
print_state_fluid = scm_permanent_object (scm_make_fluid ()); scm_print_state_vtable = type;
scm_fluid_set_x (print_state_fluid, SCM_BOOL_F);
print_state_fluid_num = SCM_FLUID_NUM (print_state_fluid);
#include "print.x" #include "print.x"
} }

15
libguile/print.h
View file

@ -56,6 +56,9 @@ extern scm_option scm_print_opts[];
/* State information passed around during printing. /* State information passed around during printing.
*/ */
#define SCM_PRINT_STATE_P(obj) (SCM_NIMP(obj) && SCM_STRUCTP(obj) && \
SCM_STRUCT_VTABLE(obj) == \
scm_print_state_vtable)
#define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj)) #define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj))
#define RESET_PRINT_STATE(pstate) \ #define RESET_PRINT_STATE(pstate) \
@ -67,9 +70,13 @@ extern scm_option scm_print_opts[];
#define SCM_WRITINGP(pstate) ((pstate)->writingp) #define SCM_WRITINGP(pstate) ((pstate)->writingp)
#define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); } #define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); }
#define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwpwuwuwuruopr" #define SCM_COERCE_OPORT(p) ((SCM_NIMP(p) && SCM_PRINT_STATE_P(SCM_CDR (p)))? \
SCM_CAR(p) : p)
#define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwuwpwuwuwuruopr"
typedef struct scm_print_state { typedef struct scm_print_state {
SCM handle; /* Struct handle */ SCM handle; /* Struct handle */
int revealed; /* Has the state escaped to Scheme? */
unsigned long writingp; /* Writing? */ unsigned long writingp; /* Writing? */
unsigned long fancyp; /* Fancy printing? */ unsigned long fancyp; /* Fancy printing? */
unsigned long level; /* Max level */ unsigned long level; /* Max level */
@ -83,6 +90,8 @@ typedef struct scm_print_state {
SCM ref_vect; SCM ref_vect;
} scm_print_state; } scm_print_state;
extern SCM scm_print_state_vtable;
extern SCM scm_print_options SCM_P ((SCM setting)); extern SCM scm_print_options SCM_P ((SCM setting));
SCM scm_make_print_state SCM_P ((void)); SCM scm_make_print_state SCM_P ((void));
void scm_free_print_state SCM_P ((SCM print_state)); void scm_free_print_state SCM_P ((SCM print_state));
@ -95,7 +104,9 @@ extern SCM scm_write SCM_P ((SCM obj, SCM port));
extern SCM scm_display SCM_P ((SCM obj, SCM port)); extern SCM scm_display SCM_P ((SCM obj, SCM port));
extern SCM scm_newline SCM_P ((SCM port)); extern SCM scm_newline SCM_P ((SCM port));
extern SCM scm_write_char SCM_P ((SCM chr, SCM port)); extern SCM scm_write_char SCM_P ((SCM chr, SCM port));
extern SCM scm_printer_apply SCM_P ((SCM proc, SCM exp, SCM port, scm_print_state *)); extern SCM scm_printer_apply SCM_P ((SCM proc, SCM exp, SCM port,
scm_print_state *));
extern int scm_valid_oport_value_p SCM_P ((SCM val));
extern void scm_init_print SCM_P ((void)); extern void scm_init_print SCM_P ((void));
#endif /* PRINTH */ #endif /* PRINTH */