mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

* * print.c (scm_iprin1, scm_prin1, scm_iprlist): Circular

Browse source 
references now have a new appearance which is more compact and
	also gives a clue about what the target of the reference is.
	By setting parameters in the print state, more fancy printing can
	be achieved.  This is used by the (not yet commited) backtrace
	code.

	* print.c: Added #include "struct.h".  Removed function
	scm_prlist.

	* print.c (scm_prin1): Print states are now allocated when calling
 	scm_prin1 and then passed around to all printing functions as an
 	argument.  A cache `print_state_pool' enables reuse of print
 	states.
	(scm_make_print_state): New function.
	(scm_iprin1): Adaption to print states.
	(scm_iprlist): An initial "hare and tortoise" scan brings down
	time complexity to O (depth * N).  (Better time complexity will be
	achieved when the printing code is completely rewritten.)

	* print.c, print.h: Closures now print like #<procedure foo (x)>.
	People who whish to see the source can do `(print-enable 'source)'.
	Removed #ifdef DEBUG_EXTENSIONS.
This commit is contained in:
Mikael Djurfeldt 1996-09-22 22:46:31 +00:00
parent 9882ea1991
commit c62fbfe1a8
1 changed files with 255 additions and 110 deletions
Download patch file Download diff file Expand all files Collapse all files

371
libguile/print.c
View file

@ -52,6 +52,7 @@
#include "weaks.h" #include "weaks.h"
#include "unif.h" #include "unif.h"
#include "alist.h" #include "alist.h"
#include "struct.h"
#include "print.h" #include "print.h"
@ -126,85 +127,144 @@ scm_print_options (setting)
*/ */
/* Detection of circular references. /* Detection of circular references.
*
* Due to other constraints in the implementation, this code has bad
* time complexity (O (depth * N)), The printer code will be
* completely rewritten before next release of Guile. The new code
* will be O(N).
*/ */
typedef struct ref_stack { #define PUSH_REF(pstate, obj) \
SCM vector;
SCM *top;
SCM *ceiling;
SCM *floor;
} ref_stack;
#define RESET_REF_STACK(stack) { stack.top = stack.floor; }
#define PUSH_REF(stack, obj, label) \
{ \ { \
register SCM *ref; \ pstate->ref_stack[pstate->top++] = (obj); \
for (ref = stack.floor; ref < stack.top; ++ref) \ if (pstate->top == pstate->ceiling) \
if (*ref == (obj)) \ grow_ref_stack (pstate); \
}
#define ENTER_NESTED_DATA(pstate, obj, label) \
{ \
register int i; \
for (i = 0; i < pstate->top; ++i) \
if (pstate->ref_stack[i] == (obj)) \
goto label; \ goto label; \
*stack.top++ = (obj); \ if (pstate->fancyp) \
if (stack.top == stack.ceiling) \
grow_ref_stack (&stack); \
} \
#define POP_REF(stack) { --stack.top; }
#define SAVE_REF_STACK(stack, save) \
{ \ { \
save = stack.floor - SCM_VELTS (stack.vector); \ if (pstate->top - pstate->list_offset >= pstate->level) \
stack.floor = stack.top; \ { \
scm_gen_putc ('#', port); \
return; \
} \
} \
PUSH_REF(pstate, obj); \
} \ } \
#define RESTORE_REF_STACK(stack, save) \ #define EXIT_NESTED_DATA(pstate) { --pstate->top; }
{ stack.floor = SCM_VELTS (stack.vector) + save; }
static SCM print_state_pool;
#if 1 /* Used for debugging purposes */
SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate);
#ifdef __STDC__ #ifdef __STDC__
static void SCM
init_ref_stack (ref_stack *stack) scm_current_pstate (void)
#else #else
static void SCM
init_ref_stack (stack) scm_current_pstate ()
ref_stack *stack;
#endif #endif
{ {
stack->vector = scm_permanent_object (scm_make_vector (SCM_MAKINUM (30L), return SCM_CADR (print_state_pool);
SCM_UNDEFINED, }
SCM_UNDEFINED)); #endif
stack->top = stack->floor = SCM_VELTS (stack->vector);
stack->ceiling = stack->floor + SCM_LENGTH (stack->vector); #define PSTATE_SIZE 50L
#ifdef __STDC__
SCM
scm_make_print_state (void)
#else
SCM
scm_make_print_state ()
#endif
{
return scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */
SCM_MAKINUM (PSTATE_SIZE),
SCM_EOL);
} }
#ifdef __STDC__ #ifdef __STDC__
static void static void
grow_ref_stack (ref_stack *stack) grow_ref_stack (scm_print_state *pstate)
#else #else
static void static void
grow_ref_stack (stack) grow_ref_stack (pstate)
ref_stack *stack; scm_print_state *pstate;
#endif #endif
{ {
int offset, new_size = 2 * SCM_LENGTH (stack->vector); int i, size = pstate->ceiling;
SCM *old_velts = SCM_VELTS (stack->vector); int total_size;
scm_vector_set_length_x (stack->vector, SCM_MAKINUM (new_size)); SCM handle;
offset = SCM_VELTS (stack->vector) - old_velts; SCM *data;
stack->top += offset; SCM_DEFER_INTS;
stack->floor += offset; handle = pstate->handle;
stack->ceiling = SCM_VELTS (stack->vector) + new_size; data = (SCM *) pstate - scm_struct_n_extra_words;
total_size = ((SCM *) pstate)[scm_struct_i_n_words];
data = (SCM *) scm_must_realloc ((char *) data,
total_size,
total_size + size,
"grow_ref_stack");
pstate = (scm_print_state *) (data + scm_struct_n_extra_words);
((SCM *) pstate)[scm_struct_i_n_words] = total_size + size;
pstate->ceiling += size;
for (i = size; i < pstate->ceiling; ++i)
pstate->ref_stack[i] = SCM_BOOL_F;
SCM_SETCDR (handle, pstate);
SCM_ALLOW_INTS;
} }
#ifdef __STDC__
static void
print_circref (SCM port, scm_print_state *pstate, SCM ref)
#else
static void
print_circref (port, pstate, ref)
SCM port;
scm_print_state *pstate;
SCM ref;
#endif
{
register int i;
int self = pstate->top - 1;
i = pstate->top - 1;
if (SCM_CONSP (pstate->ref_stack[i]))
{
while (i > 0)
{
if (SCM_NCONSP (pstate->ref_stack[i - 1])
|| SCM_CDR (pstate->ref_stack[i - 1]) != pstate->ref_stack[i])
break;
--i;
}
self = i;
}
for (i = pstate->top - 1; 1; --i)
if (pstate->ref_stack[i] == ref)
break;
scm_gen_putc ('#', port);
scm_intprint (i - self, 10, port);
scm_gen_putc ('#', port);
}
/* Print generally. Handles both write and display according to WRITING. /* Print generally. Handles both write and display according to PSTATE.
*/ */
static ref_stack pstack;
#ifdef __STDC__ #ifdef __STDC__
void void
scm_iprin1 (SCM exp, SCM port, int writing) scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
#else #else
void void
scm_iprin1 (exp, port, writing) scm_iprin1 (exp, port, pstate)
SCM exp; SCM exp;
SCM port; SCM port;
int writing; scm_print_state *pstate;
#endif #endif
{ {
register long i; register long i;
@ -219,7 +279,7 @@ taloop:
if (SCM_ICHRP (exp)) if (SCM_ICHRP (exp))
{ {
i = SCM_ICHR (exp); i = SCM_ICHR (exp);
scm_put_wchar (i, port, writing); scm_put_wchar (i, port, SCM_WRITINGP (pstate));
} }
else if (SCM_IFLAGP (exp) else if (SCM_IFLAGP (exp)
@ -259,22 +319,22 @@ taloop:
case scm_tcs_cons_imcar: case scm_tcs_cons_imcar:
case scm_tcs_cons_nimcar: case scm_tcs_cons_nimcar:
PUSH_REF (pstack, exp, circref); ENTER_NESTED_DATA (pstate, exp, circref);
scm_iprlist ("(", exp, ')', port, writing); scm_iprlist ("(", exp, ')', port, pstate);
POP_REF (pstack); EXIT_NESTED_DATA (pstate);
break; break;
circref: circref:
scm_gen_write (scm_regular_string, "#<circ ref>", sizeof ("#<circ ref>") - 1, port); print_circref (port, pstate, exp);
break; break;
case scm_tcs_closures: case scm_tcs_closures:
if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))) if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)))
{ {
SCM ans = scm_cons2 (exp, port, SCM ans = scm_cons2 (exp, port,
scm_cons (writing ? SCM_BOOL_T : SCM_BOOL_F, SCM_EOL)); scm_cons (SCM_WRITINGP (pstate)
int save; ? SCM_BOOL_T
SAVE_REF_STACK (pstack, save); : SCM_BOOL_F,
SCM_EOL));
ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL); ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL);
RESTORE_REF_STACK (pstack, save);
} }
else else
{ {
@ -287,14 +347,16 @@ taloop:
scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port); scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
scm_gen_putc (' ', port); scm_gen_putc (' ', port);
} }
scm_iprin1 (SCM_CAR (code), port, writing); scm_iprin1 (SCM_CAR (code), port, pstate);
if (SCM_PRINT_SOURCE_P) if (SCM_PRINT_SOURCE_P)
{ {
code = scm_unmemocopy (SCM_CDR (code), code = scm_unmemocopy (SCM_CDR (code),
SCM_EXTEND_ENV (SCM_CAR (code), SCM_EXTEND_ENV (SCM_CAR (code),
SCM_EOL, SCM_EOL,
SCM_ENV (exp))); SCM_ENV (exp)));
scm_iprlist (" ", code, '>', port, writing); ENTER_NESTED_DATA (pstate, exp, circref);
scm_iprlist (" ", code, '>', port, pstate);
EXIT_NESTED_DATA (pstate);
} }
else else
scm_gen_putc ('>', port); scm_gen_putc ('>', port);
@ -302,11 +364,11 @@ taloop:
break; break;
case scm_tc7_mb_string: case scm_tc7_mb_string:
case scm_tc7_mb_substring: case scm_tc7_mb_substring:
scm_print_mb_string (exp, port, writing); scm_print_mb_string (exp, port, SCM_WRITINGP (pstate));
break; break;
case scm_tc7_substring: case scm_tc7_substring:
case scm_tc7_string: case scm_tc7_string:
if (writing) if (SCM_WRITINGP (pstate))
{ {
scm_gen_putc ('"', port); scm_gen_putc ('"', port);
for (i = 0; i < SCM_ROLENGTH (exp); ++i) for (i = 0; i < SCM_ROLENGTH (exp); ++i)
@ -412,7 +474,7 @@ taloop:
break; break;
} }
case scm_tc7_wvect: case scm_tc7_wvect:
PUSH_REF (pstack, exp, circref); ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp)) if (SCM_IS_WHVEC (exp))
scm_gen_puts (scm_regular_string, "#wh(", port); scm_gen_puts (scm_regular_string, "#wh(", port);
else else
@ -420,22 +482,22 @@ taloop:
goto common_vector_printer; goto common_vector_printer;
case scm_tc7_vector: case scm_tc7_vector:
PUSH_REF (pstack, exp, circref); ENTER_NESTED_DATA (pstate, exp, circref);
scm_gen_puts (scm_regular_string, "#(", port); scm_gen_puts (scm_regular_string, "#(", port);
common_vector_printer: common_vector_printer:
for (i = 0; i + 1 < SCM_LENGTH (exp); ++i) for (i = 0; i + 1 < SCM_LENGTH (exp); ++i)
{ {
/* CHECK_INTS; */ /* CHECK_INTS; */
scm_iprin1 (SCM_VELTS (exp)[i], port, writing); scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
scm_gen_putc (' ', port); scm_gen_putc (' ', port);
} }
if (i < SCM_LENGTH (exp)) if (i < SCM_LENGTH (exp))
{ {
/* CHECK_INTS; */ /* CHECK_INTS; */
scm_iprin1 (SCM_VELTS (exp)[i], port, writing); scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
} }
scm_gen_putc (')', port); scm_gen_putc (')', port);
POP_REF (pstack); EXIT_NESTED_DATA (pstate);
break; break;
case scm_tc7_bvect: case scm_tc7_bvect:
case scm_tc7_byvect: case scm_tc7_byvect:
@ -448,7 +510,7 @@ taloop:
#ifdef LONGLONGS #ifdef LONGLONGS
case scm_tc7_llvect: case scm_tc7_llvect:
#endif #endif
scm_raprin1 (exp, port, writing); scm_raprin1 (exp, port, pstate);
break; break;
case scm_tcs_subrs: case scm_tcs_subrs:
scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port); scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
@ -461,7 +523,7 @@ taloop:
#ifdef CCLO #ifdef CCLO
case scm_tc7_cclo: case scm_tc7_cclo:
scm_gen_puts (scm_regular_string, "#<compiled-closure ", port); scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
scm_iprin1 (SCM_CCLO_SUBR (exp), port, writing); scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate);
scm_gen_putc ('>', port); scm_gen_putc ('>', port);
break; break;
#endif #endif
@ -474,19 +536,21 @@ taloop:
break; break;
case scm_tc7_port: case scm_tc7_port:
i = SCM_PTOBNUM (exp); i = SCM_PTOBNUM (exp);
if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing)) if (i < scm_numptob
&& scm_ptobs[i].print
&& (scm_ptobs[i].print) (exp, port, pstate))
break; break;
goto punk; goto punk;
case scm_tc7_smob: case scm_tc7_smob:
PUSH_REF (pstack, exp, circref); ENTER_NESTED_DATA (pstate, exp, circref);
i = SCM_SMOBNUM (exp); i = SCM_SMOBNUM (exp);
if (i < scm_numsmob && scm_smobs[i].print if (i < scm_numsmob && scm_smobs[i].print
&& (scm_smobs[i].print) (exp, port, writing)) && (scm_smobs[i].print) (exp, port, pstate))
{ {
POP_REF (pstack); EXIT_NESTED_DATA (pstate);
break; break;
} }
POP_REF (pstack); EXIT_NESTED_DATA (pstate);
default: default:
punk: punk:
scm_ipruk ("type", exp, port); scm_ipruk ("type", exp, port);
@ -494,19 +558,45 @@ taloop:
} }
} }
/* 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.
*/
#ifdef __STDC__ #ifdef __STDC__
void void
scm_prin1 (SCM exp, SCM port, int writing) scm_prin1 (SCM exp, SCM port, int writingp)
#else #else
void void
scm_prin1 (exp, port, writing) scm_prin1 (exp, port, writingp)
SCM exp; SCM exp;
SCM port; SCM port;
int writing; int writingp;
#endif #endif
{ {
RESET_REF_STACK (pstack); SCM handle = 0; /* Will GC protect the handle whilst unlinked */
scm_iprin1 (exp, port, writing); 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 (scm_make_print_state (), SCM_EOL);
pstate = (scm_print_state *) SCM_STRUCT_DATA (SCM_CAR (handle));
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;
} }
@ -558,64 +648,114 @@ scm_ipruk (hdr, ptr, port)
/* Print a list. /* Print a list.
*/ */
static ref_stack lstack;
#ifdef __STDC__ #ifdef __STDC__
void void
scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, int writing) scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, scm_print_state *pstate)
#else #else
void void
scm_iprlist (hdr, exp, tlr, port, writing) scm_iprlist (hdr, exp, tlr, port, pstate)
char *hdr; char *hdr;
SCM exp; SCM exp;
char tlr; char tlr;
SCM port; SCM port;
int writing; scm_print_state *pstate;
#endif #endif
{ {
register int i;
register SCM hare, tortoise;
int floor = pstate->top - 2;
scm_gen_puts (scm_regular_string, hdr, port); scm_gen_puts (scm_regular_string, hdr, port);
/* CHECK_INTS; */ /* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, writing); if (pstate->fancyp)
RESET_REF_STACK (lstack); goto fancy_printing;
PUSH_REF (lstack, exp, circref);
/* Run a hare and tortoise so that total time complexity will be
O(depth * N) instead of O(N^2). */
hare = SCM_CDR (exp);
tortoise = exp;
while (SCM_NIMP (hare))
{
if (hare == tortoise)
goto fancy_printing;
hare = SCM_CDR (hare);
if (SCM_IMP (hare))
break;
hare = SCM_CDR (hare);
tortoise = SCM_CDR (tortoise);
}
/* No cdr cycles intrinsic to this list */
scm_iprin1 (SCM_CAR (exp), port, pstate);
exp = SCM_CDR (exp); exp = SCM_CDR (exp);
for (; SCM_NIMP (exp); exp = SCM_CDR (exp)) for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
{ {
if (SCM_NECONSP (exp)) if (SCM_NECONSP (exp))
break; break;
PUSH_REF (lstack, exp, circref); for (i = floor; i >= 0; --i)
if (pstate->ref_stack[i] == exp)
goto circref;
PUSH_REF (pstate, exp);
scm_gen_putc (' ', port); scm_gen_putc (' ', port);
/* CHECK_INTS; */ /* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, writing); scm_iprin1 (SCM_CAR (exp), port, pstate);
} }
if (SCM_NNULLP (exp)) if (SCM_NNULLP (exp))
{ {
scm_gen_puts (scm_regular_string, " . ", port); scm_gen_puts (scm_regular_string, " . ", port);
scm_iprin1 (exp, port, writing); scm_iprin1 (exp, port, pstate);
}
end:
scm_gen_putc (tlr, port);
return;
circref:
scm_gen_puts (scm_regular_string, " . #<circ ref>", port);
goto end;
} }
#ifdef __STDC__ end:
void scm_gen_putc (tlr, port);
scm_prlist (char *hdr, SCM exp, char tlr, SCM port, int writing) pstate->top = floor + 2;
#else return;
void
scm_prlist (hdr, exp, tlr, port, writing) fancy_printing:
char *hdr;
SCM exp;
char tlr;
SCM port;
int writing;
#endif
{ {
RESET_REF_STACK (pstack); int n = pstate->length;
scm_iprlist (hdr, exp, tlr, port, writing);
scm_iprin1 (SCM_CAR (exp), port, pstate);
exp = SCM_CDR (exp); --n;
for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
{
if (SCM_NECONSP (exp))
break;
for (i = 0; i < pstate->top; ++i)
if (pstate->ref_stack[i] == exp)
goto fancy_circref;
if (pstate->fancyp)
{
if (n == 0)
{
scm_gen_puts (scm_regular_string, " ...", port);
goto skip_tail;
}
else
--n;
}
PUSH_REF(pstate, exp);
++pstate->list_offset;
scm_gen_putc (' ', port);
/* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate);
}
}
if (SCM_NNULLP (exp))
{
scm_gen_puts (scm_regular_string, " . ", port);
scm_iprin1 (exp, port, pstate);
}
skip_tail:
pstate->list_offset -= pstate->top - floor - 2;
goto end;
fancy_circref:
pstate->list_offset -= pstate->top - floor - 2;
circref:
scm_gen_puts (scm_regular_string, " . ", port);
print_circref (port, pstate, exp);
goto end;
} }
@ -735,8 +875,13 @@ void
scm_init_print () scm_init_print ()
#endif #endif
{ {
SCM vtable, type;
scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
init_ref_stack (&pstack); vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_makfrom0str ("")), SCM_INUM0, SCM_EOL);
init_ref_stack (&lstack); type = scm_make_struct (vtable,
SCM_INUM0,
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));
#include "print.x" #include "print.x"
} }