[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-15-57-g39
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-15-57-g39d41af |
|
Date: |
Fri, 11 Feb 2011 14:26:42 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=39d41afe18846ac9137d1190032994d66112e48b
The branch, master has been updated
via 39d41afe18846ac9137d1190032994d66112e48b (commit)
via 9179e8a5ff00eeb7d42b66dcdb038a35fc54d5fc (commit)
via e0c70a8b06db2f6d721556c23280471825c3830a (commit)
via 9ddf197eb2174e841b0312ed639e58d20f35132f (commit)
via e8df456a152ded4f0d7189f0770e3b08cd41674e (commit)
via eaba53b7c8156547a6eeca0385c88121a9f4b55d (commit)
via f87db65719155533036ed8c7cc686260b70a56ee (commit)
via 40b91dc897d1553e4602dff04031743040c68063 (commit)
via 423fca76e6100cf9584a5a974b1c0bbaf0b1cb85 (commit)
from 7948811252c38bb80ed6bcf8d060bc29eeac382b (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 39d41afe18846ac9137d1190032994d66112e48b
Author: Andy Wingo <address@hidden>
Date: Fri Feb 11 15:30:25 2011 +0100
better narrowing in catch-all handlers in throw.c
* libguile/throw.c (handler_message): Narrow away the catch-closure and
throw frames.
commit 9179e8a5ff00eeb7d42b66dcdb038a35fc54d5fc
Author: Andy Wingo <address@hidden>
Date: Fri Feb 11 15:21:58 2011 +0100
pre-boot lookup of print-exception works
* libguile/backtrace.c (scm_print_exception): Use scm_module_variable to
look up print-exception so that it works before boot-9 is loaded.
* libguile/throw.c (CACHE_VAR): Tweak to use scm_from_latin1_symbol.
commit e0c70a8b06db2f6d721556c23280471825c3830a
Author: Andy Wingo <address@hidden>
Date: Fri Feb 11 15:16:25 2011 +0100
scm_handle_by_message uses scm_print_exception
* libguile/throw.c (handler_message, should_print_backtrace): Use
scm_print_exception. Add a helper function to determine when to print
a backtrace; don't do so on read or syntax errors.
commit 9ddf197eb2174e841b0312ed639e58d20f35132f
Author: Andy Wingo <address@hidden>
Date: Fri Feb 11 15:03:38 2011 +0100
scm_display_error_message, display-error use print-exception
* libguile/backtrace.c (scm_display_error_message)
(scm_i_display_error): Use scm_print_exception.
commit e8df456a152ded4f0d7189f0770e3b08cd41674e
Author: Andy Wingo <address@hidden>
Date: Fri Feb 11 13:13:26 2011 +0100
print-exception gets a c binding
* libguile/backtrace.c (scm_print_exception): Add C binding for
print-exception, which dispatches to whatever is defined in Scheme.
(boot_print_exception): Add initial binding, replaced later in
Scheme.
* module/ice-9/boot-9.scm: Expect there to already be a print-exception
binding.
commit eaba53b7c8156547a6eeca0385c88121a9f4b55d
Author: Andy Wingo <address@hidden>
Date: Fri Feb 11 12:53:02 2011 +0100
repl.scm: use print-exception
* module/system/repl/repl.scm: Remove custom exception printers in favor
of print-exception.
commit f87db65719155533036ed8c7cc686260b70a56ee
Author: Andy Wingo <address@hidden>
Date: Fri Feb 11 12:45:48 2011 +0100
(system repl error-handling) uses print-exception
* module/system/repl/error-handling.scm (error-string): Just use
print-exception instead of rolling our own printer.
(call-with-error-handling): Simplify.
commit 40b91dc897d1553e4602dff04031743040c68063
Author: Andy Wingo <address@hidden>
Date: Fri Feb 11 12:44:33 2011 +0100
add set-exception-printer!, print-exception to boot-9
* module/ice-9/boot-9.scm (set-exception-printer!, print-exception):
Define an extensible exception-printing mechanism.
Also register printers for all keys thrown by Guile.
Inspired by a patch by Andreas Rottmann.
commit 423fca76e6100cf9584a5a974b1c0bbaf0b1cb85
Author: Andy Wingo <address@hidden>
Date: Fri Feb 11 12:43:05 2011 +0100
frame-source available in default environment
* libguile/frames.c (scm_frame_source): Don't call out to (system vm
frames), as this routine is used when printing exceptions. Make
available in the default environment (ugh).
* module/system/vm/frame.scm: Remove frame-source definition and
export.
-----------------------------------------------------------------------
Summary of changes:
libguile/backtrace.c | 247 ++++++++-------------------------
libguile/backtrace.h | 4 +-
libguile/frames.c | 19 ++--
libguile/throw.c | 128 ++++-------------
module/ice-9/boot-9.scm | 105 ++++++++++++++
module/system/repl/error-handling.scm | 58 ++------
module/system/repl/repl.scm | 58 +-------
module/system/vm/frame.scm | 10 +-
8 files changed, 224 insertions(+), 405 deletions(-)
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 7e93ff3..c7abe31 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -55,6 +55,43 @@
* Note that these functions shouldn't generate errors themselves.
*/
+static SCM
+boot_print_exception (SCM port, SCM frame, SCM key, SCM args)
+#define FUNC_NAME "boot-print-exception"
+{
+ scm_puts ("Throw to key ", port);
+ scm_write (key, port);
+ scm_puts (" with args ", port);
+ scm_write (args, port);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM
+scm_print_exception (SCM port, SCM frame, SCM key, SCM args)
+#define FUNC_NAME "print-exception"
+{
+ static SCM print_exception = SCM_BOOL_F;
+
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ if (scm_is_true (frame))
+ SCM_VALIDATE_FRAME (2, frame);
+ SCM_VALIDATE_SYMBOL (3, key);
+ SCM_VALIDATE_LIST (4, args);
+
+ if (scm_is_false (print_exception))
+ print_exception =
+ scm_module_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("print-exception"));
+
+ return scm_call_4 (scm_variable_ref (print_exception),
+ port, frame, key, args);
+}
+#undef FUNC_NAME
+
+
+
+
/* Print parameters for error messages. */
#define DISPLAY_ERROR_MESSAGE_MAX_LEVEL 7
@@ -72,171 +109,12 @@
if (!(_cond)) \
return SCM_BOOL_F;
-static void
-display_header (SCM source, SCM port)
-{
- if (scm_is_true (source))
- {
- /* source := (addr . (filename . (line . column))) */
- SCM fname = scm_cadr (source);
- SCM line = scm_caddr (source);
- SCM col = scm_cdddr (source);
-
- if (scm_is_true (fname))
- scm_prin1 (fname, port, 0);
- else
- scm_puts ("<unnamed port>", port);
-
- if (scm_is_true (line) && scm_is_true (col))
- {
- scm_putc (':', port);
- scm_intprint (scm_to_long (line) + 1, 10, port);
- scm_putc (':', port);
- scm_intprint (scm_to_long (col) + 1, 10, port);
- }
- }
- else
- scm_puts ("ERROR", port);
- scm_puts (": ", 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_is_string (d->message) && scm_is_true (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)
{
- 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
-display_expression (SCM frame, SCM pname, SCM source, SCM port)
-{
- SCM print_state = scm_make_print_state ();
- scm_print_state *pstate = SCM_PRINT_STATE (print_state);
- pstate->writingp = 0;
- pstate->fancyp = 1;
- pstate->level = DISPLAY_EXPRESSION_MAX_LEVEL;
- pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH;
- if (scm_is_symbol (pname) || scm_is_string (pname))
- {
- scm_puts ("In procedure ", port);
- scm_iprin1 (pname, port, pstate);
- }
- scm_puts (":\n", port);
- scm_free_print_state (print_state);
-}
-
-struct display_error_args {
- SCM frame;
- SCM port;
- SCM subr;
- SCM message;
- SCM args;
- SCM rest;
-};
-
-static SCM
-display_error_body (struct display_error_args *a)
-{
- SCM source = SCM_BOOL_F;
- SCM pname = a->subr;
-
- if (SCM_FRAMEP (a->frame))
- {
- if (scm_initialized_p)
- source = scm_frame_source (a->frame);
- if (!scm_is_symbol (pname) && !scm_is_string (pname))
- pname = scm_procedure_name (scm_frame_procedure (a->frame));
- }
-
- if (scm_is_symbol (pname) || scm_is_string (pname))
- {
- display_header (source, a->port);
- display_expression (a->frame, pname, source, a->port);
- }
- display_header (source, a->port);
- scm_display_error_message (a->message, a->args, a->port);
- return SCM_UNSPECIFIED;
-}
-
-struct display_error_handler_data {
- char *mode;
- SCM port;
-};
-
-/* This is the exception handler for error reporting routines.
- Note that it is very important that this handler *doesn't* try to
- print more than the error tag, since the error very probably is
- caused by an erroneous print call-back routine. If we would
- try to print all objects, we would enter an infinite loop. */
-static SCM
-display_error_handler (struct display_error_handler_data *data,
- SCM tag, SCM args SCM_UNUSED)
-{
- SCM print_state = scm_make_print_state ();
- scm_puts ("\nException during displaying of ", data->port);
- scm_puts (data->mode, data->port);
- scm_puts (": ", data->port);
- scm_iprin1 (tag, data->port, SCM_PRINT_STATE (print_state));
- scm_putc ('\n', data->port);
- return SCM_UNSPECIFIED;
+ scm_print_exception (port, SCM_BOOL_F, scm_misc_error_key,
+ scm_list_3 (SCM_BOOL_F, message, args));
}
@@ -248,31 +126,8 @@ display_error_handler (struct display_error_handler_data
*data,
void
scm_i_display_error (SCM frame, SCM port, SCM subr, SCM message, SCM args, SCM
rest)
{
- struct display_error_args a;
- struct display_error_handler_data data;
-
- if (SCM_FRAMEP (frame))
- a.frame = frame;
-#if SCM_ENABLE_DEPRECATED
- else if (SCM_STACKP (frame))
- {
- scm_c_issue_deprecation_warning
- ("Passing a stack to display-error is deprecated. Pass a frame
instead.");
- a.frame = scm_stack_ref (frame, SCM_INUM0);
- }
-#endif
- else
- a.frame = SCM_BOOL_F;
- a.port = port;
- a.subr = subr;
- a.message = message;
- a.args = args;
- a.rest = rest;
- data.mode = "error";
- data.port = port;
- scm_internal_catch (SCM_BOOL_T,
- (scm_t_catch_body) display_error_body, &a,
- (scm_t_catch_handler) display_error_handler, &data);
+ scm_print_exception (port, frame, scm_misc_error_key,
+ scm_list_3 (subr, message, args));
}
@@ -659,6 +514,18 @@ display_backtrace_body (struct display_backtrace_args *a)
}
#undef FUNC_NAME
+static SCM
+error_during_backtrace (void *data, SCM tag, SCM throw_args)
+{
+ SCM port = PTR2SCM (data);
+
+ scm_puts ("Exception thrown while printing backtrace:\n", port);
+ scm_print_exception (port, SCM_BOOL_F, tag, throw_args);
+
+ return SCM_UNSPECIFIED;
+}
+
+
SCM_DEFINE (scm_display_backtrace_with_highlights, "display-backtrace", 2, 3,
0,
(SCM stack, SCM port, SCM first, SCM depth, SCM highlights),
"Display a backtrace to the output port @var{port}. @var{stack}\n"
@@ -672,7 +539,6 @@ SCM_DEFINE (scm_display_backtrace_with_highlights,
"display-backtrace", 2, 3, 0,
#define FUNC_NAME s_scm_display_backtrace_with_highlights
{
struct display_backtrace_args a;
- struct display_error_handler_data data;
a.stack = stack;
a.port = port;
a.first = first;
@@ -681,11 +547,11 @@ SCM_DEFINE (scm_display_backtrace_with_highlights,
"display-backtrace", 2, 3, 0,
a.highlight_objects = SCM_EOL;
else
a.highlight_objects = highlights;
- data.mode = "backtrace";
- data.port = port;
+
scm_internal_catch (SCM_BOOL_T,
(scm_t_catch_body) display_backtrace_body, &a,
- (scm_t_catch_handler) display_error_handler, &data);
+ (scm_t_catch_handler) error_during_backtrace, SCM2PTR
(port));
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -734,6 +600,7 @@ scm_backtrace (void)
void
scm_init_backtrace ()
{
+ scm_c_define_gsubr ("print-exception", 4, 0, 0, boot_print_exception);
#include "libguile/backtrace.x"
}
diff --git a/libguile/backtrace.h b/libguile/backtrace.h
index bc593bc..42bd26f 100644
--- a/libguile/backtrace.h
+++ b/libguile/backtrace.h
@@ -3,7 +3,7 @@
#ifndef SCM_BACKTRACE_H
#define SCM_BACKTRACE_H
-/* Copyright (C) 1996,1998,1999,2000,2001, 2004, 2006, 2008, 2010 Free
Software Foundation, Inc.
+/* Copyright (C) 1996,1998,1999,2000,2001, 2004, 2006, 2008, 2010, 2011 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 License
@@ -25,6 +25,8 @@
#include "libguile/__scm.h"
+SCM_API SCM scm_print_exception (SCM port, SCM frame, SCM key, SCM args);
+
SCM_API void scm_display_error_message (SCM message, SCM args, SCM port);
SCM_INTERNAL void scm_i_display_error (SCM frame, SCM port, SCM subr,
SCM message, SCM args, SCM rest);
diff --git a/libguile/frames.c b/libguile/frames.c
index 2f87084..bc1bb82 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011 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 License
@@ -92,17 +92,18 @@ SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
}
#undef FUNC_NAME
-SCM
-scm_frame_source (SCM frame)
+SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_source
{
- static SCM var = SCM_BOOL_F;
-
- if (scm_is_false (var))
- var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
- "frame-source");
+ SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_call_1 (SCM_VARIABLE_REF (var), frame);
+ return scm_program_source (scm_frame_procedure (frame),
+ scm_frame_instruction_pointer (frame),
+ SCM_UNDEFINED);
}
+#undef FUNC_NAME
/* The number of locals would be a simple thing to compute, if it weren't for
the presence of not-yet-active frames on the stack. So we have a cheap
diff --git a/libguile/throw.c b/libguile/throw.c
index b5931fb..750e6a2 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -58,7 +58,7 @@
if (scm_is_false (var)) \
{ \
var = scm_module_variable (scm_the_root_module (), \
- scm_from_locale_symbol (name)); \
+ scm_from_latin1_symbol (name)); \
if (scm_is_false (var)) \
abort (); \
}
@@ -335,109 +335,43 @@ scm_exit_status (SCM args)
}
+static int
+should_print_backtrace (SCM tag, SCM stack)
+{
+ return SCM_BACKTRACE_P
+ && scm_is_true (stack)
+ && scm_initialized_p
+ /* It's generally not useful to print backtraces for errors reading
+ or expanding code in these fallback catch statements. */
+ && !scm_is_eq (tag, scm_from_latin1_symbol ("read-error"))
+ && !scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error"));
+}
+
static void
handler_message (void *handler_data, SCM tag, SCM args)
{
- char *prog_name = (char *) handler_data;
- SCM p = scm_current_error_port ();
-
- if (scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error"))
- && scm_ilength (args) >= 5)
+ SCM p, stack, frame;
+
+ p = scm_current_error_port ();
+ /* Usually we get here via a throw to a catch-all. In that case
+ there is the throw frame active, and the catch closure, so narrow by
+ two frames. It is possible for a user to invoke
+ scm_handle_by_message directly, though, so it could be this
+ narrows too much. We'll have to see how this works out in
+ practice. */
+ stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
+ frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
+
+ if (should_print_backtrace (tag, stack))
{
- SCM who = SCM_CAR (args);
- SCM what = SCM_CADR (args);
- SCM where = SCM_CADDR (args);
- SCM form = SCM_CADDDR (args);
- SCM subform = SCM_CAR (SCM_CDDDDR (args));
-
- scm_puts ("Syntax error:\n", p);
-
- if (scm_is_true (where))
- {
- SCM file, line, col;
-
- file = scm_assq_ref (where, scm_sym_filename);
- line = scm_assq_ref (where, scm_sym_line);
- col = scm_assq_ref (where, scm_sym_column);
-
- if (scm_is_true (file))
- scm_display (file, p);
- else
- scm_puts ("unknown file", p);
- scm_puts (":", p);
- scm_display (line, p);
- scm_puts (":", p);
- scm_display (col, p);
- scm_puts (": ", p);
- }
- else
- scm_puts ("unknown location: ", p);
-
- if (scm_is_true (who))
- {
- scm_display (who, p);
- scm_puts (": ", p);
- }
-
- scm_display (what, p);
-
- if (scm_is_true (subform))
- {
- scm_puts (" in subform ", p);
- scm_write (subform, p);
- scm_puts (" of ", p);
- scm_write (form, p);
- }
- else if (scm_is_true (form))
- {
- scm_puts (" in form ", p);
- scm_write (form, p);
- }
-
+ scm_puts ("Backtrace:\n", p);
+ scm_display_backtrace_with_highlights (stack, p,
+ SCM_BOOL_F, SCM_BOOL_F,
+ SCM_EOL);
scm_newline (p);
}
- else if (scm_ilength (args) == 4)
- {
- SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL);
- SCM subr = SCM_CAR (args);
- SCM message = SCM_CADR (args);
- SCM parts = SCM_CADDR (args);
- SCM rest = SCM_CADDDR (args);
-
- if (SCM_BACKTRACE_P && scm_is_true (stack) && scm_initialized_p)
- {
- SCM highlights;
-
- if (scm_is_eq (tag, scm_arg_type_key)
- || scm_is_eq (tag, scm_out_of_range_key))
- highlights = rest;
- else
- highlights = SCM_EOL;
-
- scm_puts ("Backtrace:\n", p);
- scm_display_backtrace_with_highlights (stack, p,
- SCM_BOOL_F, SCM_BOOL_F,
- highlights);
- scm_newline (p);
- }
- scm_i_display_error (scm_is_true (stack)
- ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F,
- p, subr, message, parts, rest);
- }
- else
- {
- if (! prog_name)
- prog_name = "guile";
-
- scm_puts (prog_name, p);
- scm_puts (": ", p);
- scm_puts ("uncaught throw to ", p);
- scm_prin1 (tag, p, 0);
- scm_puts (": ", p);
- scm_prin1 (args, p, 1);
- scm_putc ('\n', p);
- }
+ scm_print_exception (p, frame, tag, args);
}
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 83b87fd..46adc51 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -481,6 +481,111 @@ If there is no handler at all, Guile prints an error and
then exits."
+;;;
+;;; Extensible exception printing.
+;;;
+
+(define set-exception-printer! #f)
+;; There is already a definition of print-exception from backtrace.c
+;; that we will override.
+
+(let ((exception-printers '()))
+ (define (print-location frame port)
+ (let ((source (and=> frame frame-source)))
+ ;; source := (addr . (filename . (line . column)))
+ (if source
+ (let ((filename (or (cadr source) "<unnamed port>"))
+ (line (caddr source))
+ (col (cdddr source)))
+ (format port "~a:~a:~a: " filename line col))
+ (format port "ERROR: "))))
+
+ (set! set-exception-printer!
+ (lambda (key proc)
+ (set! exception-printers (acons key proc exception-printers))))
+
+ (set! print-exception
+ (lambda (port frame key args)
+ (define (default-printer)
+ (format port "Throw to key `~a' with args `~s'." key args))
+
+ (if frame
+ (let ((proc (frame-procedure frame)))
+ (print-location frame port)
+ (format port "In procedure ~a:\n"
+ (or (procedure-name proc) proc))))
+
+ (print-location frame port)
+ (catch #t
+ (lambda ()
+ (let ((printer (assq-ref exception-printers key)))
+ (if printer
+ (printer port key args default-printer)
+ (default-printer))))
+ (lambda (k . args)
+ (format port "Error while printing exception.")))
+ (newline port)
+ (force-output port))))
+
+;;;
+;;; Printers for those keys thrown by Guile.
+;;;
+(let ()
+ (define (scm-error-printer port key args default-printer)
+ ;; Abuse case-lambda as a pattern matcher, given that we don't have
+ ;; ice-9 match at this point.
+ (apply (case-lambda
+ ((subr msg args . rest)
+ (if subr
+ (format port "In procedure ~a: " subr))
+ (apply format port msg args))
+ (_ (default-printer)))
+ args))
+
+ (define (syntax-error-printer port key args default-printer)
+ (apply (case-lambda
+ ((who what where form subform extra)
+ (format port "Syntax error:\n")
+ (if where
+ (let ((file (or (assq-ref where 'filename) "unknown file"))
+ (line (and=> (assq-ref where 'line) 1+))
+ (col (assq-ref where 'column)))
+ (format port "~a:~a:~a: " file line col))
+ (format port "unknown location: "))
+ (if who
+ (format port "~a: " who))
+ (format port "~a" what)
+ (if subform
+ (format port " in subform ~s of ~s" subform form)
+ (if form
+ (format port " in form ~s" form))))
+ (_ (default-printer)))
+ args))
+
+ (set-exception-printer! 'goops-error scm-error-printer)
+ (set-exception-printer! 'host-not-found scm-error-printer)
+ (set-exception-printer! 'keyword-argument-error scm-error-printer)
+ (set-exception-printer! 'misc-error scm-error-printer)
+ (set-exception-printer! 'no-data scm-error-printer)
+ (set-exception-printer! 'no-recovery scm-error-printer)
+ (set-exception-printer! 'null-pointer-error scm-error-printer)
+ (set-exception-printer! 'out-of-range scm-error-printer)
+ (set-exception-printer! 'program-error scm-error-printer)
+ (set-exception-printer! 'read-error scm-error-printer)
+ (set-exception-printer! 'regular-expression-syntax scm-error-printer)
+ (set-exception-printer! 'signal scm-error-printer)
+ (set-exception-printer! 'stack-overflow scm-error-printer)
+ (set-exception-printer! 'system-error scm-error-printer)
+ (set-exception-printer! 'try-again scm-error-printer)
+ (set-exception-printer! 'unbound-variable scm-error-printer)
+ (set-exception-printer! 'wrong-number-of-args scm-error-printer)
+ (set-exception-printer! 'wrong-type-arg scm-error-printer)
+
+ (set-exception-printer! 'syntax-error syntax-error-printer))
+
+
+
+
;;; {Defmacros}
;;;
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index 59c44a9..d41dea6 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -29,47 +29,16 @@
-;; Temporary hacked copy of repl.scm's display-syntax error, until we
-;; merge in the proper display-exception patches.
-(define (display-syntax-error port who what where form subform extra)
- (display "Syntax error:" port)
- (newline port)
- (if where
- (let ((file (or (assq-ref where 'filename) "unknown file"))
- (line (and=> (assq-ref where 'line) 1+))
- (col (assq-ref where 'column)))
- (format port "~a:~a:~a: " file line col))
- (format port "unknown location: "))
- (if who
- (format port "~a: " who))
- (format port "~a" what)
- (if subform
- (format port " in subform ~s of ~s" subform form)
- (if form
- (format port " in form ~s" form)))
- (newline port))
-
;;;
;;; Error handling via repl debugging
;;;
(define (error-string stack key args)
- (pmatch args
- ((,who ,message ,where ,form ,subform . ,rest)
- (guard (eq? key 'syntax-error))
- (with-output-to-string
- (lambda ()
- (display-syntax-error (current-output-port)
- who message where form subform rest))))
- ((,subr ,msg ,args . ,rest)
- (guard (> (vector-length stack) 0))
- (with-output-to-string
- (lambda ()
- (display-error (vector-ref stack 0) (current-output-port)
- subr msg args rest))))
- (else
- (format #f "Throw to key `~a' with args `~s'." key args))))
-
+ (call-with-output-string
+ (lambda (port)
+ (let ((frame (and (< 0 (vector-length stack)) (vector-ref stack 0))))
+ (print-exception port frame key args)))))
+
(define* (call-with-error-handling thunk #:key
(on-error 'debug) (post-error 'catch)
(pass-keys '(quit)) (trap-handler 'debug))
@@ -133,17 +102,12 @@
(if (memq key pass-keys)
(apply throw key args)
(begin
- (pmatch args
- ((,subr ,msg ,args . ,rest)
- (with-saved-ports
- (lambda ()
- (run-hook before-error-hook)
- (display-error #f err subr msg args rest)
- (run-hook after-error-hook)
- (force-output err))))
- (else
- (format err "\nERROR: uncaught throw to `~a', args: ~a\n"
- key args)))
+ (with-saved-ports
+ (lambda ()
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err)))
(if #f #f)))))
((catch)
(lambda (key . args)
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index b135dbb..6eb29be 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -1,6 +1,6 @@
;;; Read-Eval-Print Loop
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011 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
@@ -34,29 +34,6 @@
;;;
-;;; Syntax errors
-;;;
-
-(define (display-syntax-error port who what where form subform extra)
- (format port "Syntax error:~%")
- (if where
- (let ((file (or (assq-ref where 'filename) "unknown file"))
- (line (and=> (assq-ref where 'line) 1+))
- (col (assq-ref where 'column)))
- (format port "~a:~a:~a: " file line col))
- (format port "unknown location: "))
- (if who
- (format port "~a: " who))
- (format port "~a" what)
- (if subform
- (format port " in subform ~s of ~s" subform form)
- (if form
- (format port " in form ~s" form)))
- (newline port))
-
-
-
-;;;
;;; Meta commands
;;;
@@ -93,17 +70,8 @@
((quit)
(apply throw key args))
(else
- (pmatch (cons key args)
- ((syntax-error ,who ,message ,where ,form ,subform . ,rest)
- (display-syntax-error (current-output-port)
- who message where form subform rest))
- ((_ ,subr ,msg ,args . ,rest)
- (format #t "Throw to key `~a' while reading expression:\n" key)
- (display-error #f (current-output-port) subr msg args rest))
- (else
- (format #t "Throw to key `~a' with args `~s' while reading
expression.\n"
- key args)))
- (force-output)
+ (format (current-output-port) "While reading expression:\n")
+ (print-exception (current-output-port) #f key args)
*unspecified*)))))
@@ -123,15 +91,7 @@
(lambda () exp)
(lambda (key . args)
(format #t "While ~A:~%" string)
- (pmatch (cons key args)
- ((syntax-error ,who ,message ,where ,form ,subform . ,rest)
- (display-syntax-error (current-output-port)
- who message where form subform rest))
- ((_ ,subr ,msg ,args . ,rest)
- (display-error #f (current-output-port) subr msg args rest))
- (else
- (format #t "ERROR: Throw to key `~a' with args `~s'.\n" key args)))
- (force-output)
+ (print-exception (current-output-port) #f key args)
(abort))))))
(define (run-repl repl)
@@ -158,15 +118,7 @@
(abort args)
(begin
(format #t "While executing meta-command:~%")
- (pmatch args
- ((syntax-error ,who ,message ,where ,form ,subform .
,rest)
- (display-syntax-error (current-output-port)
- who message where form subform
rest))
- ((,subr ,msg ,args . ,rest)
- (display-error #f (current-output-port) subr msg
args rest))
- (else
- (format #t "ERROR: Throw to key `~a' with args
`~s'.\n" k args)))
- (force-output))))))
+ (print-exception (current-output-port) #f k args))))))
((eof-object? exp)
(newline)
(abort '()))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 94619ba..37f621b 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,6 +1,6 @@
;;; Guile VM frame functions
-;;; Copyright (C) 2001, 2005, 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 2009, 2010, 2011 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
@@ -26,7 +26,7 @@
#:export (frame-bindings
frame-lookup-binding
frame-binding-ref frame-binding-set!
- frame-source frame-next-source frame-call-representation
+ frame-next-source frame-call-representation
frame-environment
frame-object-binding frame-object-name
frame-return-values))
@@ -70,12 +70,6 @@
;;; Pretty printing
;;;
-(define (frame-source frame)
- (let ((proc (frame-procedure frame)))
- (program-source proc
- (frame-instruction-pointer frame)
- (program-sources proc))))
-
(define (frame-next-source frame)
(let ((proc (frame-procedure frame)))
(program-source proc
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-15-57-g39d41af,
Andy Wingo <=