X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/dfd03fb91b66599064c51c2924ead945b00852c5..bc36d0502b9b2ac7e43ded2e1fbeed2f1499bb1d:/libguile/print.c diff --git a/libguile/print.c b/libguile/print.c index be50015a9..a2fe9785f 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -39,6 +39,7 @@ #include "libguile/strports.h" #include "libguile/vectors.h" #include "libguile/lang.h" +#include "libguile/numbers.h" #include "libguile/validate.h" #include "libguile/print.h" @@ -49,58 +50,21 @@ * This table must agree with the declarations in scm.h: {Immediate Symbols}. */ -char *scm_isymnames[] = +/* This table must agree with the list of flags in tags.h. */ +static const char *iflagnames[] = { - /* This table must agree with the list of SCM_IM_ constants in tags.h */ - "#@and", - "#@begin", - "#@case", - "#@cond", - "#@do", - "#@if", - "#@lambda", - "#@let", - "#@let*", - "#@letrec", - "#@or", - "#@quote", - "#@set!", - "#@define", -#if 0 - "#@literal-variable-ref", - "#@literal-variable-set!", -#endif - "#@apply", - "#@call-with-current-continuation", - - /* user visible ISYMS */ - /* other keywords */ - /* Flags */ - "#f", "#t", "#", "#", "()", "#", - "#@dispatch", - "#@slot-ref", - "#@slot-set!", - - /* Multi-language support */ - - "#@nil-cond", - "#@bind", - - "#@delay", - "#@future", - "#@call-with-values", + /* Unbound slot marker for GOOPS. For internal use in GOOPS only. */ "#", - /* Elisp nil value. This is its Scheme name; whenever it's printed - in Elisp, it should appear as the symbol `nil'. */ - + /* Elisp nil value. This is its Scheme name; whenever it's printed in + * Elisp, it should appear as the symbol `nil'. */ "#nil" }; @@ -148,7 +112,7 @@ do { \ do { \ register unsigned long i; \ for (i = 0; i < pstate->top; ++i) \ - if (SCM_EQ_P (pstate->ref_stack[i], (obj))) \ + if (scm_is_eq (pstate->ref_stack[i], (obj))) \ goto label; \ if (pstate->fancyp) \ { \ @@ -213,7 +177,7 @@ scm_make_print_state () } scm_i_plugin_mutex_unlock (&print_state_mutex); - return SCM_FALSEP (answer) ? make_print_state () : answer; + return scm_is_false (answer) ? make_print_state () : answer; } void @@ -280,15 +244,15 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref) while (i > 0) { if (!SCM_CONSP (pstate->ref_stack[i - 1]) - || !SCM_EQ_P (SCM_CDR (pstate->ref_stack[i - 1]), - pstate->ref_stack[i])) + || !scm_is_eq (SCM_CDR (pstate->ref_stack[i - 1]), + pstate->ref_stack[i])) break; --i; } self = i; } for (i = pstate->top - 1; 1; --i) - if (SCM_EQ_P (pstate->ref_stack[i], ref)) + if (scm_is_eq (pstate->ref_stack[i], ref)) break; scm_putc ('#', port); scm_intprint (i - self, 10, port); @@ -300,27 +264,34 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref) void scm_print_symbol_name (const char *str, size_t len, SCM port) { - size_t pos; + /* This points to the first character that has not yet been written to the + * port. */ + size_t pos = 0; + /* This points to the character we're currently looking at. */ size_t end; - int weird; - int maybe_weird; + /* If the name contains weird characters, we'll escape them with + * backslashes and set this flag; it indicates that we should surround the + * name with "#{" and "}#". */ + int weird = 0; + /* Backslashes are not sufficient to make a name weird, but if a name is + * weird because of other characters, backslahes need to be escaped too. + * The first time we see a backslash, we set maybe_weird, and mw_pos points + * to the backslash. Then if the name turns out to be weird, we re-process + * everything starting from mw_pos. + * We could instead make backslashes always weird. This is not necessary + * to ensure that the output is (read)-able, but it would make this code + * simpler and faster. */ + int maybe_weird = 0; size_t mw_pos = 0; - - pos = 0; - weird = 0; - maybe_weird = 0; - - /* XXX - Lots of weird symbol names are missed, such as "12" or - "'a". */ - if (len == 0) - scm_lfwrite ("#{}#", 4, port); - else if (str[0] == '#' || str[0] == ':' || str[len-1] == ':') + if (len == 0 || str[0] == '\'' || str[0] == '`' || str[0] == ',' || + str[0] == ':' || str[len-1] == ':' || (str[0] == '.' && len == 1) || + scm_is_true (scm_i_mem2number(str, len, 10))) { scm_lfwrite ("#{", 2, port); weird = 1; } - + for (end = pos; end < len; ++end) switch (str[end]) { @@ -332,6 +303,7 @@ scm_print_symbol_name (const char *str, size_t len, SCM port) case ')': case '"': case ';': + case '#': case SCM_WHITE_SPACES: case SCM_LINE_INCREMENTORS: weird_handler: @@ -346,9 +318,7 @@ scm_print_symbol_name (const char *str, size_t len, SCM port) weird = 1; } if (pos < end) - { - scm_lfwrite (str + pos, end - pos, port); - } + scm_lfwrite (str + pos, end - pos, port); { char buf[2]; buf[0] = '\\'; @@ -366,11 +336,6 @@ scm_print_symbol_name (const char *str, size_t len, SCM port) mw_pos = pos; } break; - case '}': - case '#': - if (weird) - goto weird_handler; - break; default: break; } @@ -401,7 +366,7 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) break; case scm_tc3_int_1: case scm_tc3_int_2: - scm_intprint (SCM_INUM (exp), 10, port); + scm_intprint (SCM_I_INUM (exp), 10, port); break; case scm_tc3_imm24: if (SCM_CHARP (exp)) @@ -426,14 +391,17 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_putc (i, port); } else if (SCM_IFLAGP (exp) - && ((size_t) SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *)))) - scm_puts (SCM_ISYMCHARS (exp), port); + && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *)))) + { + scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port); + } + else if (SCM_ISYMP (exp)) + { + scm_i_print_isym (exp, port); + } else if (SCM_ILOCP (exp)) { - scm_puts ("#@", port); - scm_intprint ((long) SCM_IFRAME (exp), 10, port); - scm_putc (SCM_ICDRP (exp) ? '-' : '+', port); - scm_intprint ((long) SCM_IDIST (exp), 10, port); + scm_i_print_iloc (exp, port); } else { @@ -474,8 +442,8 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) print_circref (port, pstate, exp); break; case scm_tcs_closures: - if (SCM_FALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)) - || SCM_FALSEP (scm_printer_apply (SCM_PRINT_CLOSURE, + if (scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE)) + || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE, exp, port, pstate))) { SCM formals = SCM_CLOSURE_FORMALS (exp); @@ -487,7 +455,7 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) { SCM env = SCM_ENV (exp); SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env); - SCM src = scm_unmemocopy (SCM_CODE (exp), xenv); + SCM src = scm_i_unmemocopy_body (SCM_CODE (exp), xenv); ENTER_NESTED_DATA (pstate, exp, circref); scm_iprin1 (src, port, pstate); EXIT_NESTED_DATA (pstate); @@ -497,6 +465,22 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_putc ('>', port); } break; + case scm_tc7_number: + switch SCM_TYP16 (exp) { + case scm_tc16_big: + scm_bigprint (exp, port, pstate); + break; + case scm_tc16_real: + scm_print_real (exp, port, pstate); + break; + case scm_tc16_complex: + scm_print_complex (exp, port, pstate); + break; + case scm_tc16_fraction: + scm_i_print_fraction (exp, port, pstate); + break; + } + break; case scm_tc7_string: if (SCM_WRITINGP (pstate)) { @@ -504,19 +488,28 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_putc ('"', port); for (i = 0; i < SCM_STRING_LENGTH (exp); ++i) - switch (SCM_STRING_CHARS (exp)[i]) - { - case '"': - case '\\': - scm_putc ('\\', port); - default: - scm_putc (SCM_STRING_CHARS (exp)[i], port); - } + { + unsigned char ch = SCM_STRING_CHARS (exp)[i]; + if ((ch < 32 && ch != '\n') || (127 <= ch && ch < 148)) + { + static char const hex[]="0123456789abcdef"; + scm_putc ('\\', port); + scm_putc ('x', port); + scm_putc (hex [ch / 16], port); + scm_putc (hex [ch % 16], port); + } + else + { + if (ch == '"' || ch == '\\') + scm_putc ('\\', port); + scm_putc (ch, port); + } + } scm_putc ('"', port); - break; } else - scm_lfwrite (SCM_STRING_CHARS (exp), SCM_STRING_LENGTH (exp), port); + scm_lfwrite (SCM_STRING_CHARS (exp), SCM_STRING_LENGTH (exp), + port); break; case scm_tc7_symbol: if (SCM_SYMBOL_INTERNED_P (exp)) @@ -605,12 +598,12 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_cclo: { SCM proc = SCM_CCLO_SUBR (exp); - if (SCM_EQ_P (proc, scm_f_gsubr_apply)) + if (scm_is_eq (proc, scm_f_gsubr_apply)) { /* Print gsubrs as primitives */ SCM name = scm_procedure_name (exp); scm_puts ("#revealed) + if (scm_is_true (handle) && !pstate->revealed) { scm_i_plugin_mutex_lock (&print_state_mutex); SCM_SETCDR (handle, print_state_pool); @@ -767,7 +760,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) tortoise = exp; while (SCM_CONSP (hare)) { - if (SCM_EQ_P (hare, tortoise)) + if (scm_is_eq (hare, tortoise)) goto fancy_printing; hare = SCM_CDR (hare); if (!SCM_CONSP (hare)) @@ -783,7 +776,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) register long i; for (i = floor; i >= 0; --i) - if (SCM_EQ_P (pstate->ref_stack[i], exp)) + if (scm_is_eq (pstate->ref_stack[i], exp)) goto circref; PUSH_REF (pstate, exp); scm_putc (' ', port); @@ -812,7 +805,7 @@ fancy_printing: register unsigned long i; for (i = 0; i < pstate->top; ++i) - if (SCM_EQ_P (pstate->ref_stack[i], exp)) + if (scm_is_eq (pstate->ref_stack[i], exp)) goto fancy_circref; if (pstate->fancyp) { @@ -923,11 +916,11 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, char *end; char *p; - if (SCM_EQ_P (destination, SCM_BOOL_T)) + if (scm_is_eq (destination, SCM_BOOL_T)) { destination = port = scm_cur_outp; } - else if (SCM_FALSEP (destination)) + else if (scm_is_false (destination)) { fReturnString = 1; port = scm_mkstrport (SCM_INUM0, @@ -988,7 +981,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, } scm_lfwrite (start, p - start, port); - if (!SCM_EQ_P (args, SCM_EOL)) + if (!scm_is_eq (args, SCM_EOL)) SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments", scm_list_1 (scm_length (args)));