X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/22a52da14dd86801cc3a36837601929effde1904..cea95a2fa1f2ec810f0322a038a3af33da309e4a:/libguile/print.c diff --git a/libguile/print.c b/libguile/print.c index b1f59d249..efd51ce06 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1,46 +1,20 @@ -/* Copyright (C) 1995-1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ @@ -64,6 +38,8 @@ #include "libguile/strings.h" #include "libguile/strports.h" #include "libguile/vectors.h" +#include "libguile/lang.h" +#include "libguile/numbers.h" #include "libguile/validate.h" #include "libguile/print.h" @@ -74,64 +50,40 @@ * 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 declarations */ - "#@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", - "#@nil-ify", - "#@t-ify", - "#@0-cond", - "#@0-ify", - "#@1-ify", - "#@bind", - - "#@delay", - - "#" + /* 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'. */ + "#nil" }; -scm_option scm_print_opts[] = { - { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK(SCM_BOOL_F), - "Hook for printing closures." }, +SCM_SYMBOL (sym_reader, "reader"); + +scm_t_option scm_print_opts[] = { + { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK (SCM_BOOL_F), + "Hook for printing closures (should handle macros as well)." }, { SCM_OPTION_BOOLEAN, "source", 0, - "Print closures with source." } + "Print closures with source." }, + { SCM_OPTION_SCM, "highlight-prefix", (unsigned long)SCM_BOOL_F, + "The string to print before highlighted values." }, + { SCM_OPTION_SCM, "highlight-suffix", (unsigned long)SCM_BOOL_F, + "The string to print after highlighted values." }, + { SCM_OPTION_SCM, "quote-keywordish-symbols", (unsigned long)SCM_BOOL_F, + "How to print symbols that have a colon as their first or last character. " + "The value '#f' does not quote the colons; '#t' quotes them; " + "'reader' quotes them when the reader option 'keywords' is not '#f'." + } }; SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0, @@ -160,47 +112,56 @@ SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0, * time complexity (O (depth * N)), The printer code can be * rewritten to be O(N). */ -#define PUSH_REF(pstate, obj) \ -do { \ - pstate->ref_stack[pstate->top++] = (obj); \ - if (pstate->top == pstate->ceiling) \ - grow_ref_stack (pstate); \ +#define PUSH_REF(pstate, obj) \ +do \ +{ \ + PSTATE_STACK_SET (pstate, pstate->top, obj); \ + pstate->top++; \ + if (pstate->top == pstate->ceiling) \ + grow_ref_stack (pstate); \ } while(0) -#define ENTER_NESTED_DATA(pstate, obj, label) \ -do { \ - register unsigned long i; \ - for (i = 0; i < pstate->top; ++i) \ - if (SCM_EQ_P (pstate->ref_stack[i], (obj))) \ - goto label; \ - if (pstate->fancyp) \ - { \ - if (pstate->top - pstate->list_offset >= pstate->level) \ - { \ - scm_putc ('#', port); \ - return; \ - } \ - } \ - PUSH_REF(pstate, obj); \ +#define ENTER_NESTED_DATA(pstate, obj, label) \ +do \ +{ \ + register unsigned long i; \ + for (i = 0; i < pstate->top; ++i) \ + if (scm_is_eq (PSTATE_STACK_REF (pstate, i), (obj))) \ + goto label; \ + if (pstate->fancyp) \ + { \ + if (pstate->top - pstate->list_offset >= pstate->level) \ + { \ + scm_putc ('#', port); \ + return; \ + } \ + } \ + PUSH_REF(pstate, obj); \ } while(0) -#define EXIT_NESTED_DATA(pstate) { --pstate->top; } +#define EXIT_NESTED_DATA(pstate) \ +do \ +{ \ + --pstate->top; \ + PSTATE_STACK_SET (pstate, pstate->top, SCM_UNDEFINED); \ +} \ +while (0) -SCM scm_print_state_vtable; - -static SCM print_state_pool; +SCM scm_print_state_vtable = SCM_BOOL_F; +static SCM print_state_pool = SCM_EOL; +scm_i_pthread_mutex_t print_state_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; #ifdef GUILE_DEBUG /* Used for debugging purposes */ SCM_DEFINE (scm_current_pstate, "current-pstate", 0, 0, 0, (), - "Return the current-pstate -- the cadr of the\n" + "Return the current-pstate -- the car of the\n" "@code{print_state_pool}. @code{current-pstate} is only\n" "included in @code{--enable-guile-debug} builds.") #define FUNC_NAME s_scm_current_pstate { - if (SCM_NNULLP (SCM_CDR (print_state_pool))) - return SCM_CADR (print_state_pool); + if (!scm_is_null (print_state_pool)) + return SCM_CAR (print_state_pool); else return SCM_BOOL_F; } @@ -213,13 +174,12 @@ SCM_DEFINE (scm_current_pstate, "current-pstate", 0, 0, 0, static SCM make_print_state (void) { - SCM print_state = scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */ - SCM_INUM0, - SCM_EOL); + SCM print_state + = scm_make_struct (scm_print_state_vtable, SCM_INUM0, SCM_EOL); scm_print_state *pstate = SCM_PRINT_STATE (print_state); pstate->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED); - pstate->ref_stack = SCM_VELTS (pstate->ref_vect); - pstate->ceiling = SCM_VECTOR_LENGTH (pstate->ref_vect); + pstate->ceiling = SCM_SIMPLE_VECTOR_LENGTH (pstate->ref_vect); + pstate->highlight_objects = SCM_EOL; return print_state; } @@ -229,15 +189,15 @@ scm_make_print_state () SCM answer = SCM_BOOL_F; /* First try to allocate a print state from the pool */ - SCM_DEFER_INTS; - if (SCM_NNULLP (SCM_CDR (print_state_pool))) + scm_i_pthread_mutex_lock (&print_state_mutex); + if (!scm_is_null (print_state_pool)) { - answer = SCM_CADR (print_state_pool); - SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool)); + answer = SCM_CAR (print_state_pool); + print_state_pool = SCM_CDR (print_state_pool); } - SCM_ALLOW_INTS; + scm_i_pthread_mutex_unlock (&print_state_mutex); - return SCM_FALSEP (answer) ? make_print_state () : answer; + return scm_is_false (answer) ? make_print_state () : answer; } void @@ -252,68 +212,204 @@ scm_free_print_state (SCM print_state) */ pstate->fancyp = 0; pstate->revealed = 0; - SCM_NEWCELL (handle); - SCM_DEFER_INTS; - SCM_SET_CELL_WORD_0 (handle, print_state); - SCM_SET_CELL_WORD_1 (handle, SCM_CDR (print_state_pool)); - SCM_SETCDR (print_state_pool, handle); - SCM_ALLOW_INTS; + pstate->highlight_objects = SCM_EOL; + scm_i_pthread_mutex_lock (&print_state_mutex); + handle = scm_cons (print_state, print_state_pool); + print_state_pool = handle; + scm_i_pthread_mutex_unlock (&print_state_mutex); +} + +SCM +scm_i_port_with_print_state (SCM port, SCM print_state) +{ + if (SCM_UNBNDP (print_state)) + { + if (SCM_PORT_WITH_PS_P (port)) + return port; + else + print_state = scm_make_print_state (); + /* port does not need to be coerced since it doesn't have ps */ + } + else + port = SCM_COERCE_OUTPORT (port); + SCM_RETURN_NEWSMOB (scm_tc16_port_with_ps, + SCM_UNPACK (scm_cons (port, print_state))); } static void grow_ref_stack (scm_print_state *pstate) { - unsigned long int old_size = SCM_VECTOR_LENGTH (pstate->ref_vect); - SCM *old_elts = SCM_VELTS (pstate->ref_vect); - unsigned long int new_size = 2 * pstate->ceiling; + SCM old_vect = pstate->ref_vect; + size_t old_size = SCM_SIMPLE_VECTOR_LENGTH (old_vect); + size_t new_size = 2 * pstate->ceiling; SCM new_vect = scm_c_make_vector (new_size, SCM_UNDEFINED); - SCM *new_elts = SCM_VELTS (new_vect); unsigned long int i; for (i = 0; i != old_size; ++i) - new_elts [i] = old_elts [i]; + SCM_SIMPLE_VECTOR_SET (new_vect, i, SCM_SIMPLE_VECTOR_REF (old_vect, i)); pstate->ref_vect = new_vect; - pstate->ref_stack = new_elts; pstate->ceiling = new_size; } +#define PSTATE_STACK_REF(p,i) SCM_SIMPLE_VECTOR_REF((p)->ref_vect, (i)) +#define PSTATE_STACK_SET(p,i,v) SCM_SIMPLE_VECTOR_SET((p)->ref_vect, (i), (v)) static void -print_circref (SCM port,scm_print_state *pstate,SCM ref) +print_circref (SCM port, scm_print_state *pstate, SCM ref) { - register int i; - int self = pstate->top - 1; + register long i; + long self = pstate->top - 1; i = pstate->top - 1; - if (SCM_CONSP (pstate->ref_stack[i])) + if (scm_is_pair (PSTATE_STACK_REF (pstate, i))) { while (i > 0) { - if (SCM_NCONSP (pstate->ref_stack[i - 1]) - || !SCM_EQ_P (SCM_CDR (pstate->ref_stack[i - 1]), - pstate->ref_stack[i])) + if (!scm_is_pair (PSTATE_STACK_REF (pstate, i-1)) + || !scm_is_eq (SCM_CDR (PSTATE_STACK_REF (pstate, i-1)), + SCM_CDR (PSTATE_STACK_REF (pstate, 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_STACK_REF(pstate, i), ref)) break; scm_putc ('#', port); scm_intprint (i - self, 10, port); scm_putc ('#', port); } +/* Print the name of a symbol. */ + +static int +quote_keywordish_symbol (const char *str, size_t len) +{ + SCM option; + + /* LEN is guaranteed to be > 0. + */ + if (str[0] != ':' && str[len-1] != ':') + return 0; + + option = SCM_PRINT_KEYWORD_STYLE; + if (scm_is_false (option)) + return 0; + if (scm_is_eq (option, sym_reader)) + return scm_is_true (SCM_PACK (SCM_KEYWORD_STYLE)); + return 1; +} + +void +scm_print_symbol_name (const char *str, size_t len, SCM port) +{ + /* 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; + /* 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; + + if (len == 0 || str[0] == '\'' || str[0] == '`' || str[0] == ',' + || quote_keywordish_symbol (str, len) + || (str[0] == '.' && len == 1) + || scm_is_true (scm_c_locale_stringn_to_number (str, len, 10))) + { + scm_lfwrite ("#{", 2, port); + weird = 1; + } + + for (end = pos; end < len; ++end) + switch (str[end]) + { +#ifdef BRACKETS_AS_PARENS + case '[': + case ']': +#endif + case '(': + case ')': + case '"': + case ';': + case '#': + case SCM_WHITE_SPACES: + case SCM_LINE_INCREMENTORS: + weird_handler: + if (maybe_weird) + { + end = mw_pos; + maybe_weird = 0; + } + if (!weird) + { + scm_lfwrite ("#{", 2, port); + weird = 1; + } + if (pos < end) + scm_lfwrite (str + pos, end - pos, port); + { + char buf[2]; + buf[0] = '\\'; + buf[1] = str[end]; + scm_lfwrite (buf, 2, port); + } + pos = end + 1; + break; + case '\\': + if (weird) + goto weird_handler; + if (!maybe_weird) + { + maybe_weird = 1; + mw_pos = pos; + } + break; + default: + break; + } + if (pos < end) + scm_lfwrite (str + pos, end - pos, port); + if (weird) + scm_lfwrite ("}#", 2, port); +} + /* Print generally. Handles both write and display according to PSTATE. */ SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); +static void iprin1 (SCM exp, SCM port, scm_print_state *pstate); + void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) { -taloop: + if (pstate->fancyp + && scm_is_true (scm_memq (exp, pstate->highlight_objects))) + { + scm_display (SCM_PRINT_HIGHLIGHT_PREFIX, port); + iprin1 (exp, port, pstate); + scm_display (SCM_PRINT_HIGHLIGHT_SUFFIX, port); + } + else + iprin1 (exp, port, pstate); +} + +static void +iprin1 (SCM exp, SCM port, scm_print_state *pstate) +{ switch (SCM_ITAG3 (exp)) { case scm_tc3_closure: @@ -327,7 +423,7 @@ taloop: 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)) @@ -352,14 +448,17 @@ taloop: 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 (SCM_IFRAME (exp), 10, port); - scm_putc (SCM_ICDRP (exp) ? '-' : '+', port); - scm_intprint (SCM_IDIST (exp), 10, port); + scm_i_print_iloc (exp, port); } else { @@ -367,38 +466,29 @@ taloop: scm_ipruk ("immediate", exp, port); } break; - case scm_tc3_cons_gloc: - /* gloc */ - scm_puts ("#@", port); - exp = SCM_GLOC_SYM (exp); - goto taloop; case scm_tc3_cons: switch (SCM_TYP7 (exp)) { - case scm_tcs_cons_gloc: - - if (SCM_STRUCT_VTABLE_DATA (exp) [scm_vtable_index_vcell] == 0) - { - ENTER_NESTED_DATA (pstate, exp, circref); - if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS) - { - SCM pwps, print = pstate->writingp ? g_write : g_display; - if (!print) - goto print_struct; - SCM_NEWSMOB (pwps, - scm_tc16_port_with_ps, - SCM_UNPACK (scm_cons (port, pstate->handle))); - scm_call_generic_2 (print, exp, pwps); - } - else - { - print_struct: - scm_print_struct (exp, port, pstate); - } - EXIT_NESTED_DATA (pstate); - break; - } - + case scm_tcs_struct: + { + ENTER_NESTED_DATA (pstate, exp, circref); + if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS) + { + SCM pwps, print = pstate->writingp ? g_write : g_display; + if (!print) + goto print_struct; + pwps = scm_i_port_with_print_state (port, pstate->handle); + pstate->revealed = 1; + scm_call_generic_2 (print, exp, pwps); + } + else + { + print_struct: + scm_print_struct (exp, port, pstate); + } + EXIT_NESTED_DATA (pstate); + } + break; case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: ENTER_NESTED_DATA (pstate, exp, circref); @@ -408,185 +498,111 @@ taloop: circref: print_circref (port, pstate, exp); break; - macros: - if (!SCM_CLOSUREP (SCM_CDR (exp))) - goto prinmacro; case scm_tcs_closures: - /* The user supplied print closure procedure must handle - macro closures as well. */ - 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 name, code, env; - if (SCM_MACROP (exp)) - { - /* Printing a macro. */ - prinmacro: - name = scm_macro_name (exp); - if (!SCM_CLOSUREP (SCM_CDR (exp))) - { - code = env = SCM_UNDEFINED; - scm_puts ("#', port, pstate); - EXIT_NESTED_DATA (pstate); - } - else - { - if (SCM_TYP16 (exp) != scm_tc16_macro) - { - scm_putc (' ', port); - scm_iprin1 (SCM_CAR (code), port, pstate); - } - scm_putc ('>', port); - } - } - else + { + SCM formals = SCM_CLOSURE_FORMALS (exp); + scm_puts ("#', 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_substring: case scm_tc7_string: if (SCM_WRITINGP (pstate)) { - scm_sizet i; + size_t i, j, len; + const char *data; 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); - } + len = scm_i_string_length (exp); + data = scm_i_string_chars (exp); + for (i = 0, j = 0; i < len; ++i) + { + unsigned char ch = data[i]; + if ((ch < 32 && ch != '\n') || (127 <= ch && ch < 148)) + { + static char const hex[]="0123456789abcdef"; + char buf[4]; + + scm_lfwrite (data+j, i-j, port); + buf[0] = '\\'; + buf[1] = 'x'; + buf[2] = hex [ch / 16]; + buf[3] = hex [ch % 16]; + scm_lfwrite (buf, 4, port); + data = scm_i_string_chars (exp); + j = i+1; + } + else if (ch == '"' || ch == '\\') + { + scm_lfwrite (data+j, i-j, port); + scm_putc ('\\', port); + data = scm_i_string_chars (exp); + j = i; + } + } + scm_lfwrite (data+j, i-j, port); scm_putc ('"', port); - break; + scm_remember_upto_here_1 (exp); } else - scm_lfwrite (SCM_STRING_CHARS (exp), SCM_STRING_LENGTH (exp), port); + scm_lfwrite (scm_i_string_chars (exp), scm_i_string_length (exp), + port); + scm_remember_upto_here_1 (exp); break; case scm_tc7_symbol: + if (scm_i_symbol_is_interned (exp)) { - int pos; - int end; - int len; - char * str; - int weird; - int maybe_weird; - int mw_pos = 0; - - len = SCM_SYMBOL_LENGTH (exp); - str = SCM_SYMBOL_CHARS (exp); - pos = 0; - weird = 0; - maybe_weird = 0; - - if (len == 0) - scm_lfwrite ("#{}#", 4, port); - - for (end = pos; end < len; ++end) - switch (str[end]) - { -#ifdef BRACKETS_AS_PARENS - case '[': - case ']': -#endif - case '(': - case ')': - case '"': - case ';': - case SCM_WHITE_SPACES: - case SCM_LINE_INCREMENTORS: - weird_handler: - if (maybe_weird) - { - end = mw_pos; - maybe_weird = 0; - } - if (!weird) - { - scm_lfwrite ("#{", 2, port); - weird = 1; - } - if (pos < end) - { - scm_lfwrite (str + pos, end - pos, port); - } - { - char buf[2]; - buf[0] = '\\'; - buf[1] = str[end]; - scm_lfwrite (buf, 2, port); - } - pos = end + 1; - break; - case '\\': - if (weird) - goto weird_handler; - if (!maybe_weird) - { - maybe_weird = 1; - mw_pos = pos; - } - break; - case '}': - case '#': - if (weird) - goto weird_handler; - break; - default: - break; - } - if (pos < end) - scm_lfwrite (str + pos, end - pos, port); + scm_print_symbol_name (scm_i_symbol_chars (exp), + scm_i_symbol_length (exp), + port); scm_remember_upto_here_1 (exp); - if (weird) - scm_lfwrite ("}#", 2, port); - break; } + else + { + scm_puts ("#', port); + } + break; + case scm_tc7_variable: + scm_i_variable_print (exp, port, pstate); + break; case scm_tc7_wvect: ENTER_NESTED_DATA (pstate, exp, circref); if (SCM_IS_WHVEC (exp)) @@ -601,9 +617,10 @@ taloop: common_vector_printer: { register long i; - int last = SCM_VECTOR_LENGTH (exp) - 1; + long last = SCM_SIMPLE_VECTOR_LENGTH (exp) - 1; int cutp = 0; - if (pstate->fancyp && SCM_VECTOR_LENGTH (exp) > pstate->length) + if (pstate->fancyp + && SCM_SIMPLE_VECTOR_LENGTH (exp) > pstate->length) { last = pstate->length - 1; cutp = 1; @@ -611,13 +628,13 @@ taloop: for (i = 0; i < last; ++i) { /* CHECK_INTS; */ - scm_iprin1 (SCM_VELTS (exp)[i], port, pstate); + scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate); scm_putc (' ', port); } if (i == last) { /* CHECK_INTS; */ - scm_iprin1 (SCM_VELTS (exp)[i], port, pstate); + scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate); } if (cutp) scm_puts (" ...", port); @@ -625,42 +642,27 @@ taloop: } EXIT_NESTED_DATA (pstate); break; -#ifdef HAVE_ARRAYS - case scm_tc7_bvect: - case scm_tc7_byvect: - case scm_tc7_svect: - case scm_tc7_ivect: - case scm_tc7_uvect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: -#ifdef HAVE_LONG_LONGS - case scm_tc7_llvect: -#endif - scm_raprin1 (exp, port, pstate); - break; -#endif case scm_tcs_subrs: - scm_puts (SCM_SUBR_GENERIC (exp) && *SCM_SUBR_GENERIC (exp) + scm_puts (SCM_SUBR_GENERIC (exp) ? "#', port); break; #ifdef CCLO 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 ("#writingp; pstate->writingp = writingp; scm_iprin1 (exp, port, pstate); + pstate->writingp = old_writingp; /* Return print state to pool if it has been created above and hasn't escaped to Scheme. */ - if (!SCM_FALSEP (handle) && !pstate->revealed) + if (scm_is_true (handle) && !pstate->revealed) { - SCM_DEFER_INTS; - SCM_SETCDR (handle, SCM_CDR (print_state_pool)); - SCM_SETCDR (print_state_pool, handle); - SCM_ALLOW_INTS; + scm_i_pthread_mutex_lock (&print_state_mutex); + SCM_SETCDR (handle, print_state_pool); + print_state_pool = handle; + scm_i_pthread_mutex_unlock (&print_state_mutex); } } @@ -779,12 +770,19 @@ scm_prin1 (SCM exp, SCM port, int writingp) */ void -scm_intprint (long n, int radix, SCM port) +scm_intprint (scm_t_intmax n, int radix, SCM port) { char num_buf[SCM_INTBUFLEN]; scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port); } +void +scm_uintprint (scm_t_uintmax n, int radix, SCM port) +{ + char num_buf[SCM_INTBUFLEN]; + scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port); +} + /* Print an object of unrecognized type. */ @@ -793,29 +791,27 @@ scm_ipruk (char *hdr, SCM ptr, SCM port) { scm_puts ("#', port); } -/* Print a list. The list may be either a list of ordinary data, or it may be - a list that represents code. Lists that represent code may contain gloc - cells. +/* Print a list. */ void -scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) +scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) { register SCM hare, tortoise; - int floor = pstate->top - 2; + long floor = pstate->top - 2; scm_puts (hdr, port); /* CHECK_INTS; */ if (pstate->fancyp) @@ -825,12 +821,12 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) O(depth * N) instead of O(N^2). */ hare = SCM_CDR (exp); tortoise = exp; - while (SCM_ECONSP (hare)) + while (scm_is_pair (hare)) { - if (SCM_EQ_P (hare, tortoise)) + if (scm_is_eq (hare, tortoise)) goto fancy_printing; hare = SCM_CDR (hare); - if (SCM_IMP (hare) || SCM_NECONSP (hare)) + if (!scm_is_pair (hare)) break; hare = SCM_CDR (hare); tortoise = SCM_CDR (tortoise); @@ -838,19 +834,19 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) /* No cdr cycles intrinsic to this list */ scm_iprin1 (SCM_CAR (exp), port, pstate); - for (exp = SCM_CDR (exp); SCM_ECONSP (exp); exp = SCM_CDR (exp)) + for (exp = SCM_CDR (exp); scm_is_pair (exp); exp = SCM_CDR (exp)) { - register int i; + register long i; for (i = floor; i >= 0; --i) - if (SCM_EQ_P (pstate->ref_stack[i], exp)) + if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp)) goto circref; PUSH_REF (pstate, exp); scm_putc (' ', port); /* CHECK_INTS; */ scm_iprin1 (SCM_CAR (exp), port, pstate); } - if (!SCM_NULLP (exp)) + if (!SCM_NULL_OR_NIL_P (exp)) { scm_puts (" . ", port); scm_iprin1 (exp, port, pstate); @@ -863,16 +859,16 @@ end: fancy_printing: { - int n = pstate->length; + long n = pstate->length; scm_iprin1 (SCM_CAR (exp), port, pstate); exp = SCM_CDR (exp); --n; - for (; SCM_ECONSP (exp); exp = SCM_CDR (exp)) + for (; scm_is_pair (exp); exp = SCM_CDR (exp)) { 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_STACK_REF(pstate, i), exp)) goto fancy_circref; if (pstate->fancyp) { @@ -891,7 +887,7 @@ fancy_printing: scm_iprin1 (SCM_CAR (exp), port, pstate); } } - if (SCM_NNULLP (exp)) + if (!SCM_NULL_OR_NIL_P (exp)) { scm_puts (" . ", port); scm_iprin1 (exp, port, pstate); @@ -925,7 +921,7 @@ SCM scm_write (SCM obj, SCM port) { if (SCM_UNBNDP (port)) - port = scm_cur_outp; + port = scm_current_output_port (); SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write); @@ -946,7 +942,7 @@ SCM scm_display (SCM obj, SCM port) { if (SCM_UNBNDP (port)) - port = scm_cur_outp; + port = scm_current_output_port (); SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display); @@ -976,57 +972,81 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, "containing the formatted text. Does not add a trailing newline.") #define FUNC_NAME s_scm_simple_format { - SCM answer = SCM_UNSPECIFIED; + SCM port, answer = SCM_UNSPECIFIED; int fReturnString = 0; int writingp; - char *start; - char *end; - char *p; + const char *start; + const char *end; + const char *p; - if (SCM_EQ_P (destination, SCM_BOOL_T)) + if (scm_is_eq (destination, SCM_BOOL_T)) { - destination = scm_cur_outp; + destination = port = scm_current_output_port (); } - else if (SCM_FALSEP (destination)) + else if (scm_is_false (destination)) { fReturnString = 1; - destination = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_INUM0, SCM_UNDEFINED), - SCM_OPN | SCM_WRTNG, - FUNC_NAME); + port = scm_mkstrport (SCM_INUM0, + scm_make_string (SCM_INUM0, SCM_UNDEFINED), + SCM_OPN | SCM_WRTNG, + FUNC_NAME); + destination = port; } else { SCM_VALIDATE_OPORT_VALUE (1, destination); - destination = SCM_COERCE_OUTPORT (destination); + port = SCM_COERCE_OUTPORT (destination); } SCM_VALIDATE_STRING (2, message); SCM_VALIDATE_REST_ARGUMENT (args); - start = SCM_STRING_CHARS (message); - end = start + SCM_STRING_LENGTH (message); + start = scm_i_string_chars (message); + end = start + scm_i_string_length (message); for (p = start; p != end; ++p) if (*p == '~') { - if (!SCM_CONSP (args)) - continue; - if (++p == end) - continue; - - if (*p == 'A' || *p == 'a') - writingp = 0; - else if (*p == 'S' || *p == 's') - writingp = 1; - else - continue; - - scm_lfwrite (start, p - start - 1, destination); + break; + + switch (*p) + { + case 'A': case 'a': + writingp = 0; + break; + case 'S': case 's': + writingp = 1; + break; + case '~': + scm_lfwrite (start, p - start, port); + start = p + 1; + continue; + case '%': + scm_lfwrite (start, p - start - 1, port); + scm_newline (port); + start = p + 1; + continue; + default: + SCM_MISC_ERROR ("FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead", + scm_list_1 (SCM_MAKE_CHAR (*p))); + + } + + + if (!scm_is_pair (args)) + SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A", + scm_list_1 (SCM_MAKE_CHAR (*p))); + + scm_lfwrite (start, p - start - 1, port); + /* we pass destination here */ scm_prin1 (SCM_CAR (args), destination, writingp); args = SCM_CDR (args); start = p + 1; } - scm_lfwrite (start, p - start, destination); + + scm_lfwrite (start, p - start, port); + if (!scm_is_eq (args, SCM_EOL)) + SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments", + scm_list_1 (scm_length (args))); if (fReturnString) answer = scm_strport_to_string (destination); @@ -1038,13 +1058,14 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, SCM_DEFINE (scm_newline, "newline", 0, 1, 0, (SCM port), - "Send a newline to @var{port}.") + "Send a newline to @var{port}.\n" + "If @var{port} is omitted, send to the current output port.") #define FUNC_NAME s_scm_newline { if (SCM_UNBNDP (port)) - port = scm_cur_outp; + port = scm_current_output_port (); - SCM_VALIDATE_OPORT_VALUE (1,port); + SCM_VALIDATE_OPORT_VALUE (1, port); scm_putc ('\n', SCM_COERCE_OUTPORT (port)); return SCM_UNSPECIFIED; @@ -1057,10 +1078,10 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0, #define FUNC_NAME s_scm_write_char { if (SCM_UNBNDP (port)) - port = scm_cur_outp; + port = scm_current_output_port (); - SCM_VALIDATE_CHAR (1,chr); - SCM_VALIDATE_OPORT_VALUE (2,port); + SCM_VALIDATE_CHAR (1, chr); + SCM_VALIDATE_OPORT_VALUE (2, port); scm_putc ((int) SCM_CHAR (chr), SCM_COERCE_OUTPORT (port)); #ifdef HAVE_PIPE @@ -1083,7 +1104,7 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0, * escaped to Scheme and thus has to be freed by the GC. */ -scm_bits_t scm_tc16_port_with_ps; +scm_t_bits scm_tc16_port_with_ps; /* Print exactly as the port itself would */ @@ -1097,25 +1118,23 @@ port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate) SCM scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate) { - SCM pwps; - SCM pair = scm_cons (port, pstate->handle); - SCM_NEWSMOB (pwps, scm_tc16_port_with_ps, SCM_UNPACK (pair)); pstate->revealed = 1; - return scm_apply (proc, exp, scm_cons (pwps, scm_listofnull)); + return scm_call_2 (proc, exp, + scm_i_port_with_print_state (port, pstate->handle)); } -SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 2, 0, 0, +SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 1, 1, 0, (SCM port, SCM pstate), "Create a new port which behaves like @var{port}, but with an\n" - "included print state @var{pstate}.") + "included print state @var{pstate}. @var{pstate} is optional.\n" + "If @var{pstate} isn't supplied and @var{port} already has\n" + "a print state, the old print state is reused.") #define FUNC_NAME s_scm_port_with_print_state { - SCM pwps; - SCM_VALIDATE_OPORT_VALUE (1,port); - SCM_VALIDATE_PRINTSTATE (2,pstate); - port = SCM_COERCE_OUTPORT (port); - SCM_NEWSMOB (pwps, scm_tc16_port_with_ps, SCM_UNPACK (scm_cons (port, pstate))); - return pwps; + SCM_VALIDATE_OPORT_VALUE (1, port); + if (!SCM_UNBNDP (pstate)) + SCM_VALIDATE_PRINTSTATE (2, pstate); + return scm_i_port_with_print_state (port, pstate); } #undef FUNC_NAME @@ -1139,24 +1158,31 @@ void scm_init_print () { SCM vtable, layout, type; - + scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); - vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); - layout = scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)); - type = scm_make_struct (vtable, SCM_INUM0, SCM_LIST1 (layout)); - scm_set_struct_vtable_name_x (type, scm_str2symbol ("print-state")); - print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL)); + scm_print_options (scm_list_4 (scm_from_locale_symbol ("highlight-prefix"), + scm_from_locale_string ("{"), + scm_from_locale_symbol ("highlight-suffix"), + scm_from_locale_string ("}"))); + + scm_gc_register_root (&print_state_pool); + scm_gc_register_root (&scm_print_state_vtable); + vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); + layout = + scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT)); + type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout)); + scm_set_struct_vtable_name_x (type, scm_from_locale_symbol ("print-state")); scm_print_state_vtable = type; /* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */ scm_tc16_port_with_ps = scm_make_smob_type (0, 0); scm_set_smob_mark (scm_tc16_port_with_ps, scm_markcdr); scm_set_smob_print (scm_tc16_port_with_ps, port_with_ps_print); - -#ifndef SCM_MAGIC_SNARFER + #include "libguile/print.x" -#endif + + scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader); } /*