summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/ChangeLog13
-rw-r--r--libguile/backtrace.c89
-rw-r--r--libguile/print.c84
-rw-r--r--libguile/print.h3
4 files changed, 140 insertions, 49 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index f1e675d51..627e957f2 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,5 +1,18 @@
2003-05-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+ * backtrace.c (scm_display_error_message): Introduced fancy
+ printing with max level 7 and length 10. (Purpose: avoid printing
+ gigantic objects in error messages.)
+
+ * print.c, print.h (scm_i_port_with_print_state): New function.
+
+ * print.c (scm_iprin1, scm_printer_apply,
+ scm_port_with_print_state): Use scm_i_port_with_print_state.
+ (scm_simple_format): Modified not to destroy print states.
+ (print_state_mutex): New mutex.
+ (scm_make_print_state, scm_free_print_state, scm_prin1):
+ Lock/unlock print_state_mutex.
+
* deprecated.h (SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK):
Use current names in definitions.
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 4ec2895b0..f73c80dcc 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -1,5 +1,5 @@
/* Printing of backtraces and error messages
- * Copyright (C) 1996,1997,1998,1999,2000,2001 Free Software Foundation
+ * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -40,6 +40,7 @@
#include "libguile/fluids.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
+#include "libguile/dynwind.h"
#include "libguile/validate.h"
#include "libguile/lang.h"
@@ -47,11 +48,22 @@
#include "libguile/filesys.h"
/* {Error reporting and backtraces}
- * (A first approximation.)
*
* Note that these functions shouldn't generate errors themselves.
*/
+/* Print parameters for error messages. */
+
+#define DISPLAY_ERROR_MESSAGE_MAX_LEVEL 7
+#define DISPLAY_ERROR_MESSAGE_MAX_LENGTH 10
+
+/* Print parameters for failing expressions in error messages.
+ * (See also `print_params' below for backtrace print parameters.)
+ */
+
+#define DISPLAY_EXPRESSION_MAX_LEVEL 2
+#define DISPLAY_EXPRESSION_MAX_LENGTH 3
+
#undef SCM_ASSERT
#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
if (!(_cond)) \
@@ -91,19 +103,68 @@ display_header (SCM source, SCM port)
}
+struct display_error_message_data {
+ SCM message;
+ SCM args;
+ SCM port;
+ scm_print_state *pstate;
+ int old_fancyp;
+ int old_level;
+ int old_length;
+};
+
+static SCM
+display_error_message (struct display_error_message_data *d)
+{
+ if (SCM_STRINGP (d->message) && !SCM_FALSEP (scm_list_p (d->args)))
+ scm_simple_format (d->port, d->message, d->args);
+ else
+ scm_display (d->message, d->port);
+ scm_newline (d->port);
+ return SCM_UNSPECIFIED;
+}
+
+static void
+before_display_error_message (struct display_error_message_data *d)
+{
+ scm_print_state *pstate = d->pstate;
+ d->old_fancyp = pstate->fancyp;
+ d->old_level = pstate->level;
+ d->old_length = pstate->length;
+ pstate->fancyp = 1;
+ pstate->level = DISPLAY_ERROR_MESSAGE_MAX_LEVEL;
+ pstate->length = DISPLAY_ERROR_MESSAGE_MAX_LENGTH;
+}
+
+static void
+after_display_error_message (struct display_error_message_data *d)
+{
+ scm_print_state *pstate = d->pstate;
+ pstate->fancyp = d->old_fancyp;
+ pstate->level = d->old_level;
+ pstate->length = d->old_length;
+}
+
void
scm_display_error_message (SCM message, SCM args, SCM port)
{
- if (SCM_STRINGP (message) && !SCM_FALSEP (scm_list_p (args)))
- {
- scm_simple_format (port, message, args);
- scm_newline (port);
- }
- else
- {
- scm_display (message, port);
- scm_newline (port);
- }
+ struct display_error_message_data d;
+ SCM print_state;
+ scm_print_state *pstate;
+
+ port = scm_i_port_with_print_state (port, SCM_UNDEFINED);
+ print_state = SCM_PORT_WITH_PS_PS (port);
+ pstate = SCM_PRINT_STATE (print_state);
+
+ d.message = message;
+ d.args = args;
+ d.port = port;
+ d.pstate = pstate;
+ scm_internal_dynamic_wind ((scm_t_guard) before_display_error_message,
+ (scm_t_inner) display_error_message,
+ (scm_t_guard) after_display_error_message,
+ &d,
+ &d);
}
static void
@@ -113,8 +174,8 @@ display_expression (SCM frame, SCM pname, SCM source, SCM port)
scm_print_state *pstate = SCM_PRINT_STATE (print_state);
pstate->writingp = 0;
pstate->fancyp = 1;
- pstate->level = 2;
- pstate->length = 3;
+ pstate->level = DISPLAY_EXPRESSION_MAX_LEVEL;
+ pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH;
if (SCM_SYMBOLP (pname) || SCM_STRINGP (pname))
{
if (SCM_FRAMEP (frame)
diff --git a/libguile/print.c b/libguile/print.c
index f0b8ec1d0..be50015a9 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -165,6 +165,7 @@ do { \
SCM scm_print_state_vtable = SCM_BOOL_F;
static SCM print_state_pool = SCM_EOL;
+SCM_MUTEX (print_state_mutex);
#ifdef GUILE_DEBUG /* Used for debugging purposes */
@@ -204,13 +205,13 @@ scm_make_print_state ()
SCM answer = SCM_BOOL_F;
/* First try to allocate a print state from the pool */
- SCM_DEFER_INTS;
+ scm_i_plugin_mutex_lock (&print_state_mutex);
if (!SCM_NULLP (print_state_pool))
{
answer = SCM_CAR (print_state_pool);
print_state_pool = SCM_CDR (print_state_pool);
}
- SCM_ALLOW_INTS;
+ scm_i_plugin_mutex_unlock (&print_state_mutex);
return SCM_FALSEP (answer) ? make_print_state () : answer;
}
@@ -227,10 +228,27 @@ scm_free_print_state (SCM print_state)
*/
pstate->fancyp = 0;
pstate->revealed = 0;
- SCM_DEFER_INTS;
+ scm_i_plugin_mutex_lock (&print_state_mutex);
handle = scm_cons (print_state, print_state_pool);
print_state_pool = handle;
- SCM_ALLOW_INTS;
+ scm_i_plugin_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
@@ -434,9 +452,7 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
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)));
+ pwps = scm_i_port_with_print_state (port, pstate->handle);
pstate->revealed = 1;
scm_call_generic_2 (print, exp, pwps);
}
@@ -670,13 +686,13 @@ scm_prin1 (SCM exp, SCM port, int writingp)
else
{
/* First try to allocate a print state from the pool */
- SCM_DEFER_INTS;
+ scm_i_plugin_mutex_lock (&print_state_mutex);
if (!SCM_NULLP (print_state_pool))
{
handle = print_state_pool;
print_state_pool = SCM_CDR (print_state_pool);
}
- SCM_ALLOW_INTS;
+ scm_i_plugin_mutex_unlock (&print_state_mutex);
if (SCM_FALSEP (handle))
handle = scm_list_1 (make_print_state ());
pstate_scm = SCM_CAR (handle);
@@ -693,10 +709,10 @@ scm_prin1 (SCM exp, SCM port, int writingp)
if (!SCM_FALSEP (handle) && !pstate->revealed)
{
- SCM_DEFER_INTS;
+ scm_i_plugin_mutex_lock (&print_state_mutex);
SCM_SETCDR (handle, print_state_pool);
print_state_pool = handle;
- SCM_ALLOW_INTS;
+ scm_i_plugin_mutex_unlock (&print_state_mutex);
}
}
@@ -900,7 +916,7 @@ 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;
@@ -909,20 +925,21 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
if (SCM_EQ_P (destination, SCM_BOOL_T))
{
- destination = scm_cur_outp;
+ destination = port = scm_cur_outp;
}
else if (SCM_FALSEP (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);
@@ -944,12 +961,12 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
writingp = 1;
break;
case '~':
- scm_lfwrite (start, p - start, destination);
+ scm_lfwrite (start, p - start, port);
start = p + 1;
continue;
case '%':
- scm_lfwrite (start, p - start - 1, destination);
- scm_newline (destination);
+ scm_lfwrite (start, p - start - 1, port);
+ scm_newline (port);
start = p + 1;
continue;
default:
@@ -963,13 +980,14 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A",
scm_list_1 (SCM_MAKE_CHAR (*p)));
- scm_lfwrite (start, p - start - 1, destination);
+ 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_EQ_P (args, SCM_EOL))
SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments",
scm_list_1 (scm_length (args)));
@@ -1044,25 +1062,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_call_2 (proc, exp, pwps);
+ 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;
+ if (!SCM_UNBNDP (pstate))
+ SCM_VALIDATE_PRINTSTATE (2, pstate);
+ return scm_i_port_with_print_state (port, pstate);
}
#undef FUNC_NAME
diff --git a/libguile/print.h b/libguile/print.h
index 325c65c65..b4e8292c4 100644
--- a/libguile/print.h
+++ b/libguile/print.h
@@ -3,7 +3,7 @@
#ifndef SCM_PRINT_H
#define SCM_PRINT_H
-/* Copyright (C) 1995,1996,1998,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2003 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -79,6 +79,7 @@ SCM_API scm_t_bits scm_tc16_port_with_ps;
SCM_API SCM scm_print_options (SCM setting);
SCM_API SCM scm_make_print_state (void);
SCM_API void scm_free_print_state (SCM print_state);
+SCM scm_i_port_with_print_state (SCM port, SCM print_state);
SCM_API void scm_intprint (long n, int radix, SCM port);
SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port);
SCM_API void scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate);