summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/deprecation.c4
-rw-r--r--libguile/gc-malloc.c3
-rw-r--r--libguile/load.c20
-rw-r--r--libguile/numbers.c8
-rw-r--r--libguile/poll.c1
-rw-r--r--libguile/ports.c24
-rw-r--r--libguile/ports.h2
-rw-r--r--libguile/print.c23
-rw-r--r--libguile/private-options.h5
9 files changed, 66 insertions, 24 deletions
diff --git a/libguile/deprecation.c b/libguile/deprecation.c
index 1622406a8..5c1a246c2 100644
--- a/libguile/deprecation.c
+++ b/libguile/deprecation.c
@@ -89,8 +89,8 @@ scm_c_issue_deprecation_warning (const char *msg)
fprintf (stderr, "%s\n", msg);
else
{
- scm_puts_unlocked (msg, scm_current_error_port ());
- scm_newline (scm_current_error_port ());
+ scm_puts_unlocked (msg, scm_current_warning_port ());
+ scm_newline (scm_current_warning_port ());
}
}
}
diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
index 3b64159cb..39e82ef1e 100644
--- a/libguile/gc-malloc.c
+++ b/libguile/gc-malloc.c
@@ -153,7 +153,8 @@ scm_strdup (const char *str)
void
scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
{
- /* Nothing to do. */
+ scm_gc_register_allocation (size);
+
#ifdef GUILE_DEBUG_MALLOC
if (mem)
scm_malloc_register (mem, what);
diff --git a/libguile/load.c b/libguile/load.c
index 14f411aa7..b28e30b2a 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -738,18 +738,18 @@ auto_compile_catch_handler (void *data, SCM tag, SCM throw_args)
oport = scm_open_output_string ();
scm_print_exception (oport, SCM_BOOL_F, tag, throw_args);
- scm_puts_unlocked (";;; WARNING: compilation of ", scm_current_error_port ());
- scm_display (source, scm_current_error_port ());
- scm_puts_unlocked (" failed:\n", scm_current_error_port ());
+ scm_puts_unlocked (";;; WARNING: compilation of ", scm_current_warning_port ());
+ scm_display (source, scm_current_warning_port ());
+ scm_puts_unlocked (" failed:\n", scm_current_warning_port ());
lines = scm_string_split (scm_get_output_string (oport),
SCM_MAKE_CHAR ('\n'));
for (; scm_is_pair (lines); lines = scm_cdr (lines))
if (scm_c_string_length (scm_car (lines)))
{
- scm_puts_unlocked (";;; ", scm_current_error_port ());
- scm_display (scm_car (lines), scm_current_error_port ());
- scm_newline (scm_current_error_port ());
+ scm_puts_unlocked (";;; ", scm_current_warning_port ());
+ scm_display (scm_car (lines), scm_current_warning_port ());
+ scm_newline (scm_current_warning_port ());
}
scm_close_port (oport);
@@ -767,7 +767,7 @@ SCM_DEFINE (scm_sys_warn_auto_compilation_enabled, "%warn-auto-compilation-enabl
{
scm_puts_unlocked (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n"
";;; or pass the --no-auto-compile argument to disable.\n",
- scm_current_error_port ());
+ scm_current_warning_port ());
message_shown = 1;
}
@@ -933,9 +933,9 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback,
&stat_source, &stat_compiled))
{
- scm_puts_unlocked (";;; found fresh local cache at ", scm_current_error_port ());
- scm_display (fallback, scm_current_error_port ());
- scm_newline (scm_current_error_port ());
+ scm_puts_unlocked (";;; found fresh local cache at ", scm_current_warning_port ());
+ scm_display (fallback, scm_current_warning_port ());
+ scm_newline (scm_current_warning_port ());
return scm_load_compiled_with_vm (fallback);
}
}
diff --git a/libguile/numbers.c b/libguile/numbers.c
index f15c724de..46a195a98 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -5321,8 +5321,14 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
else if (SCM_BIGP (n))
{
char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
+ size_t len = strlen (str);
+ void (*freefunc) (void *, size_t);
+ SCM ret;
+ mp_get_memory_functions (NULL, NULL, &freefunc);
scm_remember_upto_here_1 (n);
- return scm_take_locale_string (str);
+ ret = scm_from_latin1_stringn (str, len);
+ freefunc (str, len + 1);
+ return ret;
}
else if (SCM_FRACTIONP (n))
{
diff --git a/libguile/poll.c b/libguile/poll.c
index d61d51979..1bb75727b 100644
--- a/libguile/poll.c
+++ b/libguile/poll.c
@@ -184,6 +184,7 @@ scm_init_poll (void)
{
#if HAVE_POLL
scm_c_define_gsubr ("primitive-poll", 4, 0, 0, scm_primitive_poll);
+ scm_c_define ("%sizeof-struct-pollfd", scm_from_size_t (sizeof (struct pollfd)));
#else
scm_misc_error ("%init-poll", "`poll' unavailable on this platform", SCM_EOL);
#endif
diff --git a/libguile/ports.c b/libguile/ports.c
index bee2c8687..9eb6d3b9c 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -328,6 +328,17 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
}
#undef FUNC_NAME
+SCM
+scm_current_warning_port (void)
+{
+ static SCM cwp_var = SCM_BOOL_F;
+
+ if (scm_is_false (cwp_var))
+ cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
+
+ return scm_call_0 (scm_variable_ref (cwp_var));
+}
+
SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
(),
"Return the current-load-port.\n"
@@ -382,6 +393,19 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
}
#undef FUNC_NAME
+
+SCM
+scm_set_current_warning_port (SCM port)
+{
+ static SCM cwp_var = SCM_BOOL_F;
+
+ if (scm_is_false (cwp_var))
+ cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
+
+ return scm_call_1 (scm_variable_ref (cwp_var), port);
+}
+
+
void
scm_dynwind_current_input_port (SCM port)
#define FUNC_NAME NULL
diff --git a/libguile/ports.h b/libguile/ports.h
index 8c578a6df..f4a1908e0 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -241,10 +241,12 @@ SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SC
SCM_API SCM scm_current_input_port (void);
SCM_API SCM scm_current_output_port (void);
SCM_API SCM scm_current_error_port (void);
+SCM_API SCM scm_current_warning_port (void);
SCM_API SCM scm_current_load_port (void);
SCM_API SCM scm_set_current_input_port (SCM port);
SCM_API SCM scm_set_current_output_port (SCM port);
SCM_API SCM scm_set_current_error_port (SCM port);
+SCM_API SCM scm_set_current_warning_port (SCM port);
SCM_API void scm_dynwind_current_input_port (SCM port);
SCM_API void scm_dynwind_current_output_port (SCM port);
SCM_API void scm_dynwind_current_error_port (SCM port);
diff --git a/libguile/print.c b/libguile/print.c
index cdb923793..d8dd24c06 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -106,8 +106,9 @@ scm_t_option scm_print_opts[] = {
{ SCM_OPTION_SCM, "quote-keywordish-symbols", (scm_t_bits)SCM_BOOL_F_BITS,
"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'."
- },
+ "'reader' quotes them when the reader option 'keywords' is not '#f'." },
+ { SCM_OPTION_BOOLEAN, "escape-newlines", 1,
+ "Render newlines as \\n when printing using `write'." },
{ 0 },
};
@@ -1104,6 +1105,12 @@ write_character (scm_t_wchar ch, SCM port, int string_escapes_p)
display_character (ch, port, strategy);
printed = 1;
}
+ else if (ch == '\n' && SCM_PRINT_ESCAPE_NEWLINES_P)
+ {
+ display_character ('\\', port, iconveh_question_mark);
+ display_character ('n', port, strategy);
+ printed = 1;
+ }
else if (ch == ' ' || ch == '\n')
{
display_character (ch, port, strategy);
@@ -1522,13 +1529,6 @@ scm_init_print ()
{
SCM type;
- scm_init_opts (scm_print_options, scm_print_opts);
-
- scm_print_options (scm_list_4 (scm_from_latin1_symbol ("highlight-prefix"),
- scm_from_locale_string ("{"),
- scm_from_latin1_symbol ("highlight-suffix"),
- scm_from_locale_string ("}")));
-
type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT),
SCM_BOOL_F);
scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
@@ -1540,6 +1540,11 @@ scm_init_print ()
#include "libguile/print.x"
+ scm_init_opts (scm_print_options, scm_print_opts);
+ scm_print_opts[SCM_PRINT_HIGHLIGHT_PREFIX_I].val =
+ SCM_UNPACK (scm_from_locale_string ("{"));
+ scm_print_opts[SCM_PRINT_HIGHLIGHT_SUFFIX_I].val =
+ SCM_UNPACK (scm_from_locale_string ("}"));
scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader);
}
diff --git a/libguile/private-options.h b/libguile/private-options.h
index c095688c3..9d2d43cf5 100644
--- a/libguile/private-options.h
+++ b/libguile/private-options.h
@@ -45,11 +45,14 @@ SCM_INTERNAL scm_t_option scm_debug_opts[];
*/
SCM_INTERNAL scm_t_option scm_print_opts[];
+#define SCM_PRINT_HIGHLIGHT_PREFIX_I 0
#define SCM_PRINT_HIGHLIGHT_PREFIX (SCM_PACK (scm_print_opts[0].val))
+#define SCM_PRINT_HIGHLIGHT_SUFFIX_I 1
#define SCM_PRINT_HIGHLIGHT_SUFFIX (SCM_PACK (scm_print_opts[1].val))
#define SCM_PRINT_KEYWORD_STYLE_I 2
#define SCM_PRINT_KEYWORD_STYLE (SCM_PACK (scm_print_opts[2].val))
-#define SCM_N_PRINT_OPTIONS 3
+#define SCM_PRINT_ESCAPE_NEWLINES_P scm_print_opts[3].val
+#define SCM_N_PRINT_OPTIONS 4
/*