summaryrefslogtreecommitdiff
path: root/libguile/print.c
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2009-08-28 19:01:19 +0200
committerLudovic Courtès <ludo@gnu.org>2009-08-28 19:16:46 +0200
commit7af531508c5931261ff8957708642cac67bf86a5 (patch)
treebd36d27d9f7a11d954093d4121ccb9e645f5c59f /libguile/print.c
parentf86f3b5b113b4cb383c531150b13bef9b2789221 (diff)
parentce3ed0125fcfb9ad09da815f133a2320102d164c (diff)
downloadguile-7af531508c5931261ff8957708642cac67bf86a5.tar.gz
Merge branch 'master' into boehm-demers-weiser-gc
Conflicts: libguile/Makefile.am libguile/bytevectors.c libguile/gc-card.c libguile/gc-mark.c libguile/programs.c libguile/srcprop.c libguile/srfi-14.c libguile/symbols.c libguile/threads.c libguile/unif.c libguile/vm.c
Diffstat (limited to 'libguile/print.c')
-rw-r--r--libguile/print.c175
1 files changed, 112 insertions, 63 deletions
diff --git a/libguile/print.c b/libguile/print.c
index 7a4aaa3ca..c38eba76e 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -35,7 +35,7 @@
#include "libguile/procprop.h"
#include "libguile/read.h"
#include "libguile/weaks.h"
-#include "libguile/unif.h"
+#include "libguile/programs.h"
#include "libguile/alist.h"
#include "libguile/struct.h"
#include "libguile/objects.h"
@@ -294,13 +294,12 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref)
/* Print the name of a symbol. */
static int
-quote_keywordish_symbol (const char *str, size_t len)
+quote_keywordish_symbol (SCM symbol)
{
SCM option;
- /* LEN is guaranteed to be > 0.
- */
- if (str[0] != ':' && str[len-1] != ':')
+ if (scm_i_symbol_ref (symbol, 0) != ':'
+ && scm_i_symbol_ref (symbol, scm_i_symbol_length (symbol) - 1) != ':')
return 0;
option = SCM_PRINT_KEYWORD_STYLE;
@@ -312,7 +311,7 @@ quote_keywordish_symbol (const char *str, size_t len)
}
void
-scm_print_symbol_name (const char *str, size_t len, SCM port)
+scm_i_print_symbol_name (SCM str, SCM port)
{
/* This points to the first character that has not yet been written to the
* port. */
@@ -333,18 +332,20 @@ scm_print_symbol_name (const char *str, size_t len, SCM port)
* simpler and faster. */
int maybe_weird = 0;
size_t mw_pos = 0;
+ size_t len = scm_i_symbol_length (str);
+ scm_t_wchar str0 = scm_i_symbol_ref (str, 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)))
+ if (len == 0 || str0 == '\'' || str0 == '`' || str0 == ','
+ || quote_keywordish_symbol (str)
+ || (str0 == '.' && len == 1)
+ || scm_is_true (scm_i_string_to_number (scm_symbol_to_string (str), 10)))
{
scm_lfwrite ("#{", 2, port);
weird = 1;
}
for (end = pos; end < len; ++end)
- switch (str[end])
+ switch (scm_i_symbol_ref (str, end))
{
#ifdef BRACKETS_AS_PARENS
case '[':
@@ -369,11 +370,11 @@ 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_substr (scm_symbol_to_string (str), pos, end, port);
{
char buf[2];
buf[0] = '\\';
- buf[1] = str[end];
+ buf[1] = (char) (unsigned char) scm_i_symbol_ref (str, end);
scm_lfwrite (buf, 2, port);
}
pos = end + 1;
@@ -391,11 +392,18 @@ scm_print_symbol_name (const char *str, size_t len, SCM port)
break;
}
if (pos < end)
- scm_lfwrite (str + pos, end - pos, port);
+ scm_lfwrite_substr (scm_symbol_to_string (str), pos, end, port);
if (weird)
scm_lfwrite ("}#", 2, port);
}
+void
+scm_print_symbol_name (const char *str, size_t len, SCM port)
+{
+ SCM symbol = scm_from_locale_symboln (str, len);
+ return scm_i_print_symbol_name (symbol, port);
+}
+
/* Print generally. Handles both write and display according to PSTATE.
*/
SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write);
@@ -454,20 +462,50 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
| UC_CATEGORY_MASK_S))
/* Print the character if is graphic character. */
{
- if (i<256)
- /* Character is graphic. Print it. */
- scm_putc (i, port);
+ scm_t_wchar *wbuf;
+ SCM wstr = scm_i_make_wide_string (1, &wbuf);
+ char *buf;
+ size_t len;
+ const char *enc;
+
+ enc = scm_i_get_port_encoding (port);
+ wbuf[0] = i;
+ if (enc == NULL)
+ {
+ if (i <= 0xFF)
+ /* Character is graphic and Latin-1. Print it */
+ scm_lfwrite_str (wstr, port);
+ else
+ /* Character is graphic but unrepresentable in
+ this port's encoding. */
+ scm_intprint (i, 8, port);
+ }
else
- /* Character is graphic but unrepresentable in
- this port's encoding. */
- scm_intprint (i, 8, port);
+ {
+ buf = u32_conv_to_encoding (enc,
+ iconveh_error,
+ (scm_t_uint32 *) wbuf,
+ 1,
+ NULL,
+ NULL, &len);
+ if (buf != NULL)
+ {
+ /* Character is graphic. Print it. */
+ scm_lfwrite_str (wstr, port);
+ free (buf);
+ }
+ else
+ /* Character is graphic but unrepresentable in
+ this port's encoding. */
+ scm_intprint (i, 8, port);
+ }
}
else
/* Character is a non-graphical character. */
scm_intprint (i, 8, port);
}
else
- scm_putc (i, port);
+ scm_i_charprint (i, port);
}
else if (SCM_IFLAGP (exp)
&& ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *))))
@@ -599,21 +637,32 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
SCM wstr = scm_i_make_wide_string (1, &wbuf);
char *buf;
size_t len;
-
- wbuf[0] = ch;
-
- buf = u32_conv_to_encoding ("ISO-8859-1",
- iconveh_error,
- (scm_t_uint32 *) wbuf,
- 1, NULL, NULL, &len);
- if (buf != NULL)
+
+ if (scm_i_get_port_encoding (port))
{
- /* Character is graphic and representable in
- this encoding. Print it. */
- scm_lfwrite_str (wstr, port);
- free (buf);
- printed = 1;
+ wstr = scm_i_make_wide_string (1, &wbuf);
+ wbuf[0] = ch;
+ buf = u32_conv_to_encoding (scm_i_get_port_encoding (port),
+ iconveh_error,
+ (scm_t_uint32 *) wbuf,
+ 1 ,
+ NULL,
+ NULL, &len);
+ if (buf != NULL)
+ {
+ /* Character is graphic and representable in
+ this encoding. Print it. */
+ scm_lfwrite_str (wstr, port);
+ free (buf);
+ printed = 1;
+ }
}
+ else
+ if (ch <= 0xFF)
+ {
+ scm_putc (ch, port);
+ printed = 1;
+ }
}
if (!printed)
@@ -658,23 +707,19 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_remember_upto_here_1 (exp);
}
else
- scm_lfwrite (scm_i_string_chars (exp), scm_i_string_length (exp),
- port);
+ scm_lfwrite_str (exp, port);
scm_remember_upto_here_1 (exp);
break;
case scm_tc7_symbol:
if (scm_i_symbol_is_interned (exp))
{
- scm_print_symbol_name (scm_i_symbol_chars (exp),
- scm_i_symbol_length (exp), port);
+ scm_i_print_symbol_name (exp, port);
scm_remember_upto_here_1 (exp);
}
else
{
scm_puts ("#<uninterned-symbol ", port);
- scm_print_symbol_name (scm_i_symbol_chars (exp),
- scm_i_symbol_length (exp),
- port);
+ scm_i_print_symbol_name (exp, port);
scm_putc (' ', port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
scm_putc ('>', port);
@@ -683,6 +728,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_variable:
scm_i_variable_print (exp, port, pstate);
break;
+ case scm_tc7_program:
+ scm_i_program_print (exp, port, pstate);
+ break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp))
@@ -737,14 +785,16 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
EXIT_NESTED_DATA (pstate);
break;
case scm_tcs_subrs:
- scm_puts (SCM_SUBR_GENERIC (exp)
- ? "#<primitive-generic "
- : "#<primitive-procedure ",
- port);
- scm_puts (scm_i_symbol_chars (SCM_SUBR_NAME (exp)), port);
- scm_putc ('>', port);
- break;
-
+ {
+ SCM name = scm_symbol_to_string (SCM_SUBR_NAME (exp));
+ scm_puts (SCM_SUBR_GENERIC (exp)
+ ? "#<primitive-generic "
+ : "#<primitive-procedure ",
+ port);
+ scm_lfwrite_str (name, port);
+ scm_putc ('>', port);
+ break;
+ }
case scm_tc7_pws:
scm_puts ("#<procedure-with-setter", port);
{
@@ -839,7 +889,7 @@ scm_prin1 (SCM exp, SCM port, int writingp)
/* Print a character.
*/
void
-scm_i_charprint (scm_t_uint32 ch, SCM port)
+scm_i_charprint (scm_t_wchar ch, SCM port)
{
scm_t_wchar *wbuf;
SCM wstr = scm_i_make_wide_string (1, &wbuf);
@@ -1061,9 +1111,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
SCM port, answer = SCM_UNSPECIFIED;
int fReturnString = 0;
int writingp;
- const char *start;
- const char *end;
- const char *p;
+ size_t start, p, end;
if (scm_is_eq (destination, SCM_BOOL_T))
{
@@ -1086,15 +1134,16 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
SCM_VALIDATE_STRING (2, message);
SCM_VALIDATE_REST_ARGUMENT (args);
- start = scm_i_string_chars (message);
- end = start + scm_i_string_length (message);
+ p = 0;
+ start = 0;
+ end = scm_i_string_length (message);
for (p = start; p != end; ++p)
- if (*p == '~')
+ if (scm_i_string_ref (message, p) == '~')
{
if (++p == end)
break;
- switch (*p)
+ switch (scm_i_string_ref (message, p))
{
case 'A': case 'a':
writingp = 0;
@@ -1103,33 +1152,33 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
writingp = 1;
break;
case '~':
- scm_lfwrite (start, p - start, port);
+ scm_lfwrite_substr (message, start, p, port);
start = p + 1;
continue;
case '%':
- scm_lfwrite (start, p - start - 1, port);
+ scm_lfwrite_substr (message, start, p - 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)));
+ scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p))));
}
if (!scm_is_pair (args))
SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A",
- scm_list_1 (SCM_MAKE_CHAR (*p)));
+ scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p))));
- scm_lfwrite (start, p - start - 1, port);
+ scm_lfwrite_substr (message, start, p - 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, port);
+ scm_lfwrite_substr (message, start, p, port);
if (!scm_is_eq (args, SCM_EOL))
SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments",
scm_list_1 (scm_length (args)));