From c4f37e8038bd9be15c9816a59babf99069771687 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 27 Jul 1997 09:08:38 +0000 Subject: [PATCH] * print.c (scm_iprin1): Enter printed structures into the print state as nested data while they are printed. (print_state_fluid, print_state_fluid_num): New variables. (scm_init_print): Initialize them. (scm_iprin): If print_state_fluid carries a print_state, use that instead of creating a new one. (scm_printer_apply, apply_stub, struct apply_data): New definitions to help with calling printer functions written in Scheme. * print.h (scm_printer_apply): New prototype. --- libguile/print.c | 102 ++++++++++++++++++++++++++++++++++++++--------- libguile/print.h | 1 + 2 files changed, 84 insertions(+), 19 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 93c545062..238862b4b 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -53,6 +53,7 @@ #include "unif.h" #include "alist.h" #include "struct.h" +#include "fluids.h" #include "print.h" @@ -157,6 +158,17 @@ scm_print_options (setting) 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); @@ -320,7 +332,9 @@ taloop: if (SCM_CDR (SCM_CAR (exp) - 1L) == 0) { + ENTER_NESTED_DATA (pstate, exp, circref); scm_print_struct (exp, port, pstate); + EXIT_NESTED_DATA (pstate); break; } @@ -587,30 +601,41 @@ scm_prin1 (exp, port, writingp) SCM port; int writingp; { - SCM handle = 0; /* Will GC protect the handle whilst unlinked */ + SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */ + SCM pstate_scm; scm_print_state *pstate; - /* First try to allocate a print state from the pool */ - SCM_DEFER_INTS; - if (SCM_NNULLP (SCM_CDR (print_state_pool))) - { - handle = SCM_CDR (print_state_pool); - SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool)); - } - SCM_ALLOW_INTS; - - if (!handle) - handle = scm_cons (make_print_state (), SCM_EOL); + /* If there is currently a print state active, use that. Else + create a new one. */ - pstate = SCM_PRINT_STATE (SCM_CAR (handle)); + pstate_scm = SCM_FAST_FLUID_REF (print_state_fluid_num); + if (pstate_scm == SCM_BOOL_F) + { + /* First try to allocate a print state from the pool */ + SCM_DEFER_INTS; + if (SCM_NNULLP (SCM_CDR (print_state_pool))) + { + handle = SCM_CDR (print_state_pool); + SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool)); + } + SCM_ALLOW_INTS; + if (handle == SCM_BOOL_F) + handle = scm_cons (make_print_state (), SCM_EOL); + pstate_scm = SCM_CAR (handle); + } + + pstate = SCM_PRINT_STATE (pstate_scm); pstate->writingp = writingp; scm_iprin1 (exp, port, pstate); - /* Return print state to pool */ - SCM_DEFER_INTS; - SCM_SETCDR (handle, SCM_CDR (print_state_pool)); - SCM_SETCDR (print_state_pool, handle); - SCM_ALLOW_INTS; + /* Return print state to pool, if it has been created above. */ + if (handle != SCM_BOOL_F) + { + SCM_DEFER_INTS; + SCM_SETCDR (handle, SCM_CDR (print_state_pool)); + SCM_SETCDR (print_state_pool, handle); + SCM_ALLOW_INTS; + } } @@ -850,14 +875,48 @@ scm_write_char (chr, port) return SCM_UNSPECIFIED; } - +/* 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); +} + +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); +} + + void scm_init_print () { SCM vtable, type; + scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr), SCM_INUM0, SCM_EOL); type = scm_make_struct (vtable, @@ -865,5 +924,10 @@ scm_init_print () scm_cons (scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)), 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); + #include "print.x" } diff --git a/libguile/print.h b/libguile/print.h index 5824d8a39..592c82b1d 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -95,6 +95,7 @@ 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 void scm_init_print SCM_P ((void)); #endif /* PRINTH */