mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +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 "alist.h"
#include "struct.h"
#include "fluids.h"
#include "print.h"
@ -156,19 +155,10 @@ scm_print_options (setting)
#define EXIT_NESTED_DATA(pstate) { --pstate->top; }
SCM scm_print_state_vtable;
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 */
SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate);
@ -227,6 +217,7 @@ scm_free_print_state (print_state)
* often.
*/
pstate->fancyp = 0;
pstate->revealed = 0;
SCM_NEWCELL (handle);
SCM_DEFER_INTS;
SCM_SETCAR (handle, print_state);
@ -353,72 +344,65 @@ taloop:
case scm_tcs_closures:
/* The user supplied print closure procedure must handle
macro closures as well. */
if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)))
{
SCM ans = scm_cons2 (exp, port,
scm_cons (SCM_WRITINGP (pstate)
? SCM_BOOL_T
: SCM_BOOL_F,
SCM_EOL));
ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL);
}
else
{
SCM name, code;
if (SCM_TYP16 (exp) == scm_tc16_macro)
{
/* Printing a macro. */
prinmacro:
name = scm_macro_name (exp);
if (!SCM_CLOSUREP (SCM_CDR (exp)))
{
code = 0;
scm_gen_puts (scm_regular_string, "#<primitive-",
port);
}
else
{
code = SCM_CODE (SCM_CDR (exp));
scm_gen_puts (scm_regular_string, "#<", port);
}
if (SCM_CAR (exp) & (3L << 16))
scm_gen_puts (scm_regular_string, "macro", port);
else
scm_gen_puts (scm_regular_string, "syntax", port);
if (SCM_CAR (exp) & (2L << 16))
scm_gen_putc ('!', port);
}
else
{
/* Printing a closure. */
name = scm_procedure_name (exp);
code = SCM_CODE (exp);
scm_gen_puts (scm_regular_string, "#<procedure",
port);
}
if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
{
scm_gen_putc (' ', port);
scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
}
if (code)
{
scm_gen_putc (' ', port);
scm_iprin1 (SCM_CAR (code), port, pstate);
}
if (code && SCM_PRINT_SOURCE_P)
{
code = scm_unmemocopy (SCM_CDR (code),
SCM_EXTEND_ENV (SCM_CAR (code),
SCM_EOL,
SCM_ENV (exp)));
ENTER_NESTED_DATA (pstate, exp, circref);
scm_iprlist (" ", code, '>', port, pstate);
EXIT_NESTED_DATA (pstate);
}
else
scm_gen_putc ('>', port);
}
if (SCM_FALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))
|| SCM_FALSEP (scm_printer_apply (SCM_PRINT_CLOSURE,
exp, port, pstate)));
{
SCM name, code;
if (SCM_TYP16 (exp) == scm_tc16_macro)
{
/* Printing a macro. */
prinmacro:
name = scm_macro_name (exp);
if (!SCM_CLOSUREP (SCM_CDR (exp)))
{
code = 0;
scm_gen_puts (scm_regular_string, "#<primitive-",
port);
}
else
{
code = SCM_CODE (SCM_CDR (exp));
scm_gen_puts (scm_regular_string, "#<", port);
}
if (SCM_CAR (exp) & (3L << 16))
scm_gen_puts (scm_regular_string, "macro", port);
else
scm_gen_puts (scm_regular_string, "syntax", port);
if (SCM_CAR (exp) & (2L << 16))
scm_gen_putc ('!', port);
}
else
{
/* Printing a closure. */
name = scm_procedure_name (exp);
code = SCM_CODE (exp);
scm_gen_puts (scm_regular_string, "#<procedure",
port);
}
if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
{
scm_gen_putc (' ', port);
scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
}
if (code)
{
scm_gen_putc (' ', port);
scm_iprin1 (SCM_CAR (code), port, pstate);
}
if (code && SCM_PRINT_SOURCE_P)
{
code = scm_unmemocopy (SCM_CDR (code),
SCM_EXTEND_ENV (SCM_CAR (code),
SCM_EOL,
SCM_ENV (exp)));
ENTER_NESTED_DATA (pstate, exp, circref);
scm_iprlist (" ", code, '>', port, pstate);
EXIT_NESTED_DATA (pstate);
}
else
scm_gen_putc ('>', port);
}
break;
case scm_tc7_mb_string:
case scm_tc7_mb_substring:
@ -638,6 +622,10 @@ taloop:
* 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
scm_prin1 (exp, port, writingp)
SCM exp;
@ -648,11 +636,15 @@ scm_prin1 (exp, port, writingp)
SCM pstate_scm;
scm_print_state *pstate;
/* If there is currently a print state active, use that. Else
create a new one. */
/* If PORT is a print-state/port pair, use that. Else create a new
print-state. */
pstate_scm = SCM_FAST_FLUID_REF (print_state_fluid_num);
if (pstate_scm == SCM_BOOL_F)
if (SCM_NIMP (port) && SCM_CONSP (port))
{
pstate_scm = SCM_CDR (port);
port = SCM_CAR (port);
}
else
{
/* First try to allocate a print state from the pool */
SCM_DEFER_INTS;
@ -671,8 +663,10 @@ scm_prin1 (exp, port, writingp)
pstate->writingp = writingp;
scm_iprin1 (exp, port, pstate);
/* Return print state to pool, if it has been created above. */
if (handle != SCM_BOOL_F)
/* Return print state to pool if it has been created above and
hasn't escaped to Scheme. */
if (handle != SCM_BOOL_F && !pstate->revealed)
{
SCM_DEFER_INTS;
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
@ -840,7 +843,8 @@ scm_write (obj, port)
if (SCM_UNBNDP (port))
port = scm_cur_outp;
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);
#ifdef HAVE_PIPE
# ifdef EPIPE
@ -862,7 +866,8 @@ scm_display (obj, port)
if (SCM_UNBNDP (port))
port = scm_cur_outp;
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);
#ifdef HAVE_PIPE
# ifdef EPIPE
@ -880,10 +885,11 @@ scm_newline (port)
SCM port;
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
port = scm_cur_outp;
else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline);
scm_gen_putc ('\n', port);
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG1, s_newline);
scm_gen_putc ('\n', SCM_COERCE_OPORT (port));
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
@ -904,11 +910,12 @@ scm_write_char (chr, port)
SCM port;
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
port = scm_cur_outp;
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_gen_putc ((int) SCM_ICHR (chr), port);
scm_gen_putc ((int) SCM_ICHR (chr), SCM_COERCE_OPORT (port));
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
@ -920,39 +927,23 @@ scm_write_char (chr, port)
/* Routines for calling back to Scheme code to do the printing of
special objects (like structs). SCM_PRINTER_APPLY applies PROC to EXP
and PORT while the print_state_fluid is set to PSTATE. When PROC
inturn calls `display' or `write', this print_state is picked up and
used to control the printing. */
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);
}
/* Call back to Scheme code to do the printing of special objects
(like structs). SCM_PRINTER_APPLY applies PROC to EXP and a pair
containing PORT and PSTATE. This pair 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
scm_printer_apply (proc, exp, port, pstate)
SCM proc, exp, port;
scm_print_state *pstate;
{
struct apply_data cl;
cl.proc = proc;
cl.arg1 = exp;
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);
SCM pair = scm_cons (port, pstate->handle);
pstate->revealed = 1;
return scm_apply (proc, exp, scm_cons (pair, scm_listofnull));
}
void
@ -968,9 +959,7 @@ scm_init_print ()
SCM_EOL));
print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL));
print_state_fluid = scm_permanent_object (scm_make_fluid ());
scm_fluid_set_x (print_state_fluid, SCM_BOOL_F);
print_state_fluid_num = SCM_FLUID_NUM (print_state_fluid);
scm_print_state_vtable = type;
#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.
*/
#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 RESET_PRINT_STATE(pstate) \
@ -67,9 +70,13 @@ extern scm_option scm_print_opts[];
#define SCM_WRITINGP(pstate) ((pstate)->writingp)
#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 {
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 */
@ -83,6 +90,8 @@ typedef struct scm_print_state {
SCM ref_vect;
} scm_print_state;
extern SCM scm_print_state_vtable;
extern SCM scm_print_options SCM_P ((SCM setting));
SCM scm_make_print_state SCM_P ((void));
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_newline SCM_P ((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));
#endif /* PRINTH */