diff options
author | Andy Wingo <wingo@pobox.com> | 2011-02-11 13:13:26 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-02-11 13:13:26 +0100 |
commit | e8df456a152ded4f0d7189f0770e3b08cd41674e (patch) | |
tree | 1a2b19fb6e2fa8eddbe8211042187db39b395786 | |
parent | eaba53b7c8156547a6eeca0385c88121a9f4b55d (diff) | |
download | guile-e8df456a152ded4f0d7189f0770e3b08cd41674e.tar.gz |
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.
-rw-r--r-- | libguile/backtrace.c | 38 | ||||
-rw-r--r-- | libguile/backtrace.h | 4 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 3 |
3 files changed, 43 insertions, 2 deletions
diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 7e93ff3f5..70bb7fba9 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -55,6 +55,42 @@ * 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_c_module_lookup (scm_the_root_module (), + "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,6 +108,7 @@ if (!(_cond)) \ return SCM_BOOL_F; + static void display_header (SCM source, SCM port) { @@ -734,6 +771,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 bc593bcc7..42bd26f2a 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/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 66cec58d6..46adc512b 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -486,7 +486,8 @@ If there is no handler at all, Guile prints an error and then exits." ;;; (define set-exception-printer! #f) -(define print-exception #f) +;; There is already a definition of print-exception from backtrace.c +;; that we will override. (let ((exception-printers '())) (define (print-location frame port) |