mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 12:20:26 +02:00
Code Activity

print-exception gets a c binding

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-02-11 13:13:26 +01:00
parent eaba53b7c8
commit e8df456a15
3 changed files with 43 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

38
libguile/backtrace.c
View file

@ -55,6 +55,42 @@
* Note that these functions shouldn't generate errors themselves. * 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. */ /* Print parameters for error messages. */
#define DISPLAY_ERROR_MESSAGE_MAX_LEVEL 7 #define DISPLAY_ERROR_MESSAGE_MAX_LEVEL 7
@ -72,6 +108,7 @@
if (!(_cond)) \ if (!(_cond)) \
return SCM_BOOL_F; return SCM_BOOL_F;
static void static void
display_header (SCM source, SCM port) display_header (SCM source, SCM port)
{ {
@ -734,6 +771,7 @@ scm_backtrace (void)
void void
scm_init_backtrace () scm_init_backtrace ()
{ {
scm_c_define_gsubr ("print-exception", 4, 0, 0, boot_print_exception);
#include "libguile/backtrace.x" #include "libguile/backtrace.x"
} }

4
libguile/backtrace.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_BACKTRACE_H #ifndef SCM_BACKTRACE_H
#define 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -25,6 +25,8 @@
#include "libguile/__scm.h" #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_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_INTERNAL void scm_i_display_error (SCM frame, SCM port, SCM subr,
SCM message, SCM args, SCM rest); SCM message, SCM args, SCM rest);

3
module/ice-9/boot-9.scm
View file

@ -486,7 +486,8 @@ If there is no handler at all, Guile prints an error and then exits."
;;; ;;;
(define set-exception-printer! #f) (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 '())) (let ((exception-printers '()))
(define (print-location frame port) (define (print-location frame port)