X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/a51ea417bad631b3375051e8f52274a7b3056f3b..1595aa56c6537a9112aa31226b1567a0fc5ddb0c:/libguile/print.c diff --git a/libguile/print.c b/libguile/print.c index 805f92c25..adc70482c 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -51,6 +51,8 @@ #include "read.h" #include "weaks.h" #include "unif.h" +#include "alist.h" +#include "struct.h" #include "print.h" @@ -96,23 +98,18 @@ char *scm_isymnames[] = "#" }; -#ifdef DEBUG_EXTENSIONS scm_option scm_print_opts[] = { - { SCM_OPTION_BOOLEAN, "procnames", 0, - "Print names instead of closures." }, { SCM_OPTION_SCM, "closure-hook", SCM_BOOL_F, - "Procedure used to print closures." } + "Hook for printing closures." }, + { SCM_OPTION_BOOLEAN, "source", 0, + "Print closures with source." } }; SCM_PROC (s_print_options, "print-options-interface", 0, 1, 0, scm_print_options); -#ifdef __STDC__ -SCM -scm_print_options (SCM setting) -#else + SCM scm_print_options (setting) SCM setting; -#endif { SCM ans = scm_options (setting, scm_print_opts, @@ -120,93 +117,164 @@ scm_print_options (setting) s_print_options); return ans; } -#endif /* {Printing of Scheme Objects} */ /* 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 { - 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) \ +#define PUSH_REF(pstate, obj) \ { \ - register SCM *ref; \ - for (ref = stack.floor; ref < stack.top; ++ref) \ - if (*ref == (obj)) \ - goto label; \ - *stack.top++ = (obj); \ - if (stack.top == stack.ceiling) \ - grow_ref_stack (&stack); \ -} \ + pstate->ref_stack[pstate->top++] = (obj); \ + if (pstate->top == pstate->ceiling) \ + grow_ref_stack (pstate); \ +} -#define POP_REF(stack) { --stack.top; } -#define SAVE_REF_STACK(stack, save) \ +#define ENTER_NESTED_DATA(pstate, obj, label) \ { \ - save = stack.floor - SCM_VELTS (stack.vector); \ - stack.floor = stack.top; \ + register int i; \ + for (i = 0; i < pstate->top; ++i) \ + if (pstate->ref_stack[i] == (obj)) \ + goto label; \ + if (pstate->fancyp) \ + { \ + if (pstate->top - pstate->list_offset >= pstate->level) \ + { \ + scm_gen_putc ('#', port); \ + return; \ + } \ + } \ + PUSH_REF(pstate, obj); \ } \ -#define RESTORE_REF_STACK(stack, save) \ -{ stack.floor = SCM_VELTS (stack.vector) + save; } +#define EXIT_NESTED_DATA(pstate) { --pstate->top; } -#ifdef __STDC__ -static void -init_ref_stack (ref_stack *stack) -#else -static void -init_ref_stack (stack) - ref_stack *stack; +static SCM print_state_pool; + +#if 1 /* Used for debugging purposes */ +SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate); + +SCM +scm_current_pstate () +{ + return SCM_CADR (print_state_pool); +} #endif + +#define PSTATE_SIZE 50L + +static SCM make_print_state SCM_P ((void)); + +static SCM +make_print_state () { - stack->vector = scm_permanent_object (scm_make_vector (SCM_MAKINUM (30L), - SCM_UNDEFINED, - SCM_UNDEFINED)); - stack->top = stack->floor = SCM_VELTS (stack->vector); - stack->ceiling = stack->floor + SCM_LENGTH (stack->vector); + SCM print_state = scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */ + SCM_INUM0, + SCM_EOL); + scm_print_state *pstate = SCM_PRINT_STATE (print_state); + pstate->ref_vect = scm_make_vector (SCM_MAKINUM (PSTATE_SIZE), + SCM_UNDEFINED, + SCM_UNDEFINED); + pstate->ref_stack = SCM_VELTS (pstate->ref_vect); + pstate->ceiling = SCM_LENGTH (pstate->ref_vect); + return print_state; } -#ifdef __STDC__ -static void -grow_ref_stack (ref_stack *stack) -#else +SCM +scm_make_print_state () +{ + SCM answer = 0; + + /* First try to allocate a print state from the pool */ + SCM_DEFER_INTS; + if (SCM_NNULLP (SCM_CDR (print_state_pool))) + { + answer = SCM_CADR (print_state_pool); + SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool)); + } + SCM_ALLOW_INTS; + + return answer ? answer : make_print_state (); +} + +void +scm_free_print_state (print_state) + SCM print_state; +{ + SCM handle; + scm_print_state *pstate = SCM_PRINT_STATE (print_state); + /* Cleanup before returning print state to pool. + * It is better to do it here. Doing it in scm_prin1 + * would cost more since that function is called much more + * often. + */ + pstate->fancyp = 0; + SCM_NEWCELL (handle); + SCM_DEFER_INTS; + SCM_SETCAR (handle, print_state); + SCM_SETCDR (handle, SCM_CDR (print_state_pool)); + SCM_SETCDR (print_state_pool, handle); + SCM_ALLOW_INTS; +} + +static void grow_ref_stack SCM_P ((scm_print_state *pstate)); + static void -grow_ref_stack (stack) - ref_stack *stack; -#endif +grow_ref_stack (pstate) + scm_print_state *pstate; { - int offset, new_size = 2 * SCM_LENGTH (stack->vector); - SCM *old_velts = SCM_VELTS (stack->vector); - scm_vector_set_length_x (stack->vector, SCM_MAKINUM (new_size)); - offset = SCM_VELTS (stack->vector) - old_velts; - stack->top += offset; - stack->floor += offset; - stack->ceiling = SCM_VELTS (stack->vector) + new_size; + int new_size = 2 * pstate->ceiling; + scm_vector_set_length_x (pstate->ref_vect, SCM_MAKINUM (new_size)); + pstate->ref_stack = SCM_VELTS (pstate->ref_vect); + pstate->ceiling = new_size; } -/* Print generally. Handles both write and display according to WRITING. +static void print_circref SCM_P ((SCM port, scm_print_state *pstate, SCM ref)); + +static void +print_circref (port, pstate, ref) + SCM port; + scm_print_state *pstate; + SCM ref; +{ + 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 PSTATE. */ -static ref_stack pstack; -#ifdef __STDC__ void -scm_iprin1 (SCM exp, SCM port, int writing) -#else -void -scm_iprin1 (exp, port, writing) +scm_iprin1 (exp, port, pstate) SCM exp; SCM port; - int writing; -#endif + scm_print_state *pstate; { register long i; taloop: @@ -220,12 +288,12 @@ taloop: if (SCM_ICHRP (exp)) { i = SCM_ICHR (exp); - scm_put_wchar (i, port, writing); + scm_put_wchar (i, port, SCM_WRITINGP (pstate)); } else if (SCM_IFLAGP (exp) && (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *)))) - scm_gen_puts (scm_regular_string, SCM_ISYMSCM_CHARS (exp), port); + scm_gen_puts (scm_regular_string, SCM_ISYMCHARS (exp), port); else if (SCM_ILOCP (exp)) { scm_gen_puts (scm_regular_string, "#@", port); @@ -260,67 +328,68 @@ taloop: case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: - PUSH_REF (pstack, exp, circref); - scm_iprlist ("(", exp, ')', port, writing); - POP_REF (pstack); + ENTER_NESTED_DATA (pstate, exp, circref); + scm_iprlist ("(", exp, ')', port, pstate); + EXIT_NESTED_DATA (pstate); break; circref: - scm_gen_write (scm_regular_string, "#", sizeof ("#") - 1, port); + print_circref (port, pstate, exp); break; case scm_tcs_closures: -#ifdef DEBUG_EXTENSIONS if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))) { SCM ans = scm_cons2 (exp, port, - scm_cons (writing ? SCM_BOOL_T : SCM_BOOL_F, SCM_EOL)); - int save; - SAVE_REF_STACK (pstack, save); + scm_cons (SCM_WRITINGP (pstate) + ? SCM_BOOL_T + : SCM_BOOL_F, + SCM_EOL)); ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL); - RESTORE_REF_STACK (pstack, save); } - else if (SCM_PRINT_PROCNAMES_P) + else { - SCM name; + SCM name, code; name = scm_procedure_property (exp, scm_i_name); - scm_gen_puts (scm_regular_string, "#', port); - } - else -#endif - { - SCM code = SCM_CODE (exp); - exp = scm_unmemocopy (code, - SCM_EXTEND_SCM_ENV (SCM_CAR (code), - SCM_EOL, - SCM_ENV (exp))); - scm_iprlist ("#', port, writing); + scm_iprin1 (SCM_CAR (code), port, pstate); + if (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: - scm_print_mb_string (exp, port, writing); + scm_print_mb_string (exp, port, SCM_WRITINGP (pstate)); break; case scm_tc7_substring: 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) switch (SCM_ROCHARS (exp)[i]) { - case '\"': + case '"': case '\\': scm_gen_putc ('\\', port); default: scm_gen_putc (SCM_ROCHARS (exp)[i], port); } - scm_gen_putc ('\"', port); + scm_gen_putc ('"', port); break; } else @@ -342,7 +411,7 @@ taloop: char * str; int weird; int maybe_weird; - int mw_pos; + int mw_pos = 0; len = SCM_LENGTH (exp); str = SCM_CHARS (exp); @@ -363,7 +432,7 @@ taloop: #endif case '(': case ')': - case '\"': + case '"': case ';': case SCM_WHITE_SPACES: case SCM_LINE_INCREMENTORS: @@ -414,7 +483,7 @@ taloop: break; } case scm_tc7_wvect: - PUSH_REF (pstack, exp, circref); + ENTER_NESTED_DATA (pstate, exp, circref); if (SCM_IS_WHVEC (exp)) scm_gen_puts (scm_regular_string, "#wh(", port); else @@ -422,22 +491,22 @@ taloop: goto common_vector_printer; case scm_tc7_vector: - PUSH_REF (pstack, exp, circref); + ENTER_NESTED_DATA (pstate, exp, circref); scm_gen_puts (scm_regular_string, "#(", port); common_vector_printer: for (i = 0; i + 1 < SCM_LENGTH (exp); ++i) { /* CHECK_INTS; */ - scm_iprin1 (SCM_VELTS (exp)[i], port, writing); + scm_iprin1 (SCM_VELTS (exp)[i], port, pstate); scm_gen_putc (' ', port); } if (i < SCM_LENGTH (exp)) { /* CHECK_INTS; */ - scm_iprin1 (SCM_VELTS (exp)[i], port, writing); + scm_iprin1 (SCM_VELTS (exp)[i], port, pstate); } scm_gen_putc (')', port); - POP_REF (pstack); + EXIT_NESTED_DATA (pstate); break; case scm_tc7_bvect: case scm_tc7_byvect: @@ -450,7 +519,7 @@ taloop: #ifdef LONGLONGS case scm_tc7_llvect: #endif - scm_raprin1 (exp, port, writing); + scm_raprin1 (exp, port, pstate); break; case scm_tcs_subrs: scm_gen_puts (scm_regular_string, "#', port); break; #endif @@ -476,19 +545,21 @@ taloop: break; case scm_tc7_port: 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; goto punk; case scm_tc7_smob: - PUSH_REF (pstack, exp, circref); + ENTER_NESTED_DATA (pstate, exp, circref); i = SCM_SMOBNUM (exp); 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; } - POP_REF (pstack); + EXIT_NESTED_DATA (pstate); default: punk: scm_ipruk ("type", exp, port); @@ -496,34 +567,52 @@ taloop: } } -#ifdef __STDC__ -void -scm_prin1 (SCM exp, SCM port, int writing) -#else +/* 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. + */ + void -scm_prin1 (exp, port, writing) +scm_prin1 (exp, port, writingp) SCM exp; SCM port; - int writing; -#endif + int writingp; { - RESET_REF_STACK (pstack); - scm_iprin1 (exp, port, writing); + SCM handle = 0; /* Will GC protect the handle whilst unlinked */ + 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); + + pstate = SCM_PRINT_STATE (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; } /* Print an integer. */ -#ifdef __STDC__ -void -scm_intprint (long n, int radix, SCM port) -#else + void scm_intprint (n, radix, port) long n; int radix; SCM port; -#endif { char num_buf[SCM_INTBUFLEN]; scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port); @@ -531,16 +620,12 @@ scm_intprint (n, radix, port) /* Print an object of unrecognized type. */ -#ifdef __STDC__ -void -scm_ipruk (char *hdr, SCM ptr, SCM port) -#else + void scm_ipruk (hdr, ptr, port) char *hdr; SCM ptr; SCM port; -#endif { scm_gen_puts (scm_regular_string, "#top - 2; scm_gen_puts (scm_regular_string, hdr, port); /* CHECK_INTS; */ - scm_iprin1 (SCM_CAR (exp), port, writing); - RESET_REF_STACK (lstack); - PUSH_REF (lstack, exp, circref); + if (pstate->fancyp) + goto fancy_printing; + + /* 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) && SCM_ECONSP (hare)) + { + if (hare == tortoise) + goto fancy_printing; + hare = SCM_CDR (hare); + if (SCM_IMP (hare) || SCM_NECONSP (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); for (; SCM_NIMP (exp); exp = SCM_CDR (exp)) { if (SCM_NECONSP (exp)) 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); /* CHECK_INTS; */ - scm_iprin1 (SCM_CAR (exp), port, writing); + scm_iprin1 (SCM_CAR (exp), port, pstate); } if (SCM_NNULLP (exp)) { scm_gen_puts (scm_regular_string, " . ", port); - scm_iprin1 (exp, port, writing); + scm_iprin1 (exp, port, pstate); } + end: scm_gen_putc (tlr, port); + pstate->top = floor + 2; return; -circref: - scm_gen_puts (scm_regular_string, " . #", port); + +fancy_printing: + { + int n = pstate->length; + + 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; -} -#ifdef __STDC__ -void -scm_prlist (char *hdr, SCM exp, char tlr, SCM port, int writing) -#else -void -scm_prlist (hdr, exp, tlr, port, writing) - char *hdr; - SCM exp; - char tlr; - SCM port; - int writing; -#endif -{ - RESET_REF_STACK (pstack); - scm_iprlist (hdr, exp, tlr, port, writing); +fancy_circref: + pstate->list_offset -= pstate->top - floor - 2; + +circref: + scm_gen_puts (scm_regular_string, " . ", port); + print_circref (port, pstate, exp); + goto end; } SCM_PROC(s_write, "write", 1, 1, 0, scm_write); -#ifdef __STDC__ -SCM -scm_write (SCM obj, SCM port) -#else + SCM scm_write (obj, port) SCM obj; SCM port; -#endif { if (SCM_UNBNDP (port)) port = scm_cur_outp; @@ -649,15 +776,11 @@ scm_write (obj, port) SCM_PROC(s_display, "display", 1, 1, 0, scm_display); -#ifdef __STDC__ -SCM -scm_display (SCM obj, SCM port) -#else + SCM scm_display (obj, port) SCM obj; SCM port; -#endif { if (SCM_UNBNDP (port)) port = scm_cur_outp; @@ -674,14 +797,10 @@ scm_display (obj, port) } SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline); -#ifdef __STDC__ -SCM -scm_newline(SCM port) -#else + SCM scm_newline (port) SCM port; -#endif { if (SCM_UNBNDP (port)) port = scm_cur_outp; @@ -701,15 +820,11 @@ scm_newline (port) } SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char); -#ifdef __STDC__ -SCM -scm_write_char (SCM chr, SCM port) -#else + SCM scm_write_char (chr, port) SCM chr; SCM port; -#endif { if (SCM_UNBNDP (port)) port = scm_cur_outp; @@ -729,18 +844,17 @@ scm_write_char (chr, port) -#ifdef __STDC__ -void -scm_init_print (void) -#else + void scm_init_print () -#endif { -#ifdef DEBUG_EXTENSIONS + SCM vtable, type; scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); - init_ref_stack (&pstack); - init_ref_stack (&lstack); -#endif + vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr), SCM_INUM0, SCM_EOL); + 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" }