Most errors were reported as coming from boot-9.scm due to incorrect
hard-coded stack-narrowing offsets. This patch fixes the offsets and
adds an argument to specify additional frames to skip when calling
raise-exception.
* libguile/stacks.h:
* libguile/stacks.c (scm_skip_stack_frames_fluid): New internal var.
(scm_init_stacks): Define %skip-stack-frames and initialize to 0.
* libguile/continuations.c (print_exception_and_backtrace):
* libguile/throw.c (handler_message): Use scm_skip_stack_frames_fluid to
accurately trim the stack.
* module/ice-9/boot-9.scm (raise-exception): Add #:skip-frames kwarg.
Call handler with %skip-stack-frames set appropriately.
(throw): Call raise-exception with #:skip-frames 1.
* module/ice-9/threads.scm (call-with-new-thread):
* module/system/repl/error-handling.scm (call-with-error-handling): Use
%skip-stack-frames to accurately trim the stack.
---
libguile/continuations.c | 12 +++++++-----
libguile/stacks.c | 5 +++++
libguile/stacks.h | 1 +
libguile/throw.c | 15 +++++++--------
module/ice-9/boot-9.scm | 19 +++++++++++++++----
module/ice-9/threads.scm | 6 +++---
module/system/repl/error-handling.scm | 10 ++++++----
7 files changed, 44 insertions(+), 24 deletions(-)
diff --git a/libguile/continuations.c b/libguile/continuations.c
index b8b6e1dca..227be46f9 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -38,6 +38,7 @@
#include "debug.h"
#include "dynstack.h"
#include "eval.h"
+#include "fluids.h"
#include "gsubr.h"
#include "init.h"
#include "instructions.h"
@@ -395,12 +396,13 @@ should_print_backtrace (SCM tag, SCM stack)
static void
print_exception_and_backtrace (SCM port, SCM tag, SCM args)
{
- SCM stack, frame;
+ SCM skip, stack, frame;
- /* We get here via a throw to a catch-all. In that case there is the
- throw frame active, and this catch closure, so narrow by two
- frames. */
- stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
+ /* We get here via a throw to a catch-all. Narrow by the number of
+ frames specified in %skip-stack-frames to get an accurate error
+ location. */
+ skip = scm_fluid_ref (scm_skip_stack_frames_fluid);
+ stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (skip));
frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
if (should_print_backtrace (tag, stack))
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 36842920b..5c7d57a06 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -48,6 +48,8 @@
#include "stacks.h"
+SCM scm_skip_stack_frames_fluid;
+
static SCM scm_sys_stacks;
@@ -473,5 +475,8 @@ scm_init_stacks ()
SCM_UNDEFINED);
scm_set_struct_vtable_name_x (scm_stack_type,
scm_from_utf8_symbol ("stack"));
+
+ scm_skip_stack_frames_fluid = scm_make_fluid_with_default (SCM_INUM0);
+ scm_c_define ("%skip-stack-frames", scm_skip_stack_frames_fluid);
#include "stacks.x"
}
diff --git a/libguile/stacks.h b/libguile/stacks.h
index 25ece853a..39d0433ac 100644
--- a/libguile/stacks.h
+++ b/libguile/stacks.h
@@ -59,6 +59,7 @@ SCM_API SCM scm_stack_id (SCM stack);
SCM_API SCM scm_stack_ref (SCM stack, SCM i);
SCM_API SCM scm_stack_length (SCM stack);
+SCM_INTERNAL SCM scm_skip_stack_frames_fluid;
SCM_INTERNAL void scm_init_stacks (void);
#endif /* SCM_STACKS_H */
diff --git a/libguile/throw.c b/libguile/throw.c
index e837abe89..468ed0241 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -366,16 +366,15 @@ should_print_backtrace (SCM tag, SCM stack)
static void
handler_message (void *handler_data, SCM tag, SCM args)
{
- SCM p, stack, frame;
+ SCM p, skip, 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)));
+ /* Usually we get here via a throw to a catch-all, though it is
+ possible for a user to invoke scm_handle_by_message directly.
+ Narrow by the number of frames specified in %skip-stack-frames to
+ get an accurate error location. */
+ skip = scm_fluid_ref (scm_skip_stack_frames_fluid);
+ stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (skip));
frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
if (should_print_backtrace (tag, stack))
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a46145ed5..f5080fe2e 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1628,7 +1628,7 @@ exception that is an instance of @var{rtd}."
(exception-kind exn) (exception-args exn))
(primitive-exit 1))))
- (define* (raise-exception exn #:key (continuable? #f))
+ (define* (raise-exception exn #:key (continuable? #f) (skip-frames 0))
"Raise an exception by invoking the current exception handler on
@var{exn}. The handler is called with a continuation whose dynamic
environment is that of the call to @code{raise}, except that the current
@@ -1638,7 +1638,14 @@ called was installed.
If @var{continuable?} is true, the handler is invoked in tail position
relative to the @code{raise-exception} call. Otherwise if the handler
returns, a non-continuable exception of type @code{&non-continuable} is
-raised in the same dynamic environment as the handler."
+raised in the same dynamic environment as the handler.
+
+The @var{skip-frames} argument can be used to specify a number of
+additional stack frames to skip when determining the error location.
+This is useful for helper functions which raise an exception but
+shouldn't be reported as the source of the error. The default value of
+0 will treat the caller of @code{raise-exception} as the source of the
+error."
(define (capture-current-exception-handlers)
;; FIXME: This is quadratic.
(let lp ((depth 0))
@@ -1677,7 +1684,11 @@ raised in the same dynamic environment as the handler."
(else
(lp handlers)))))
(else
- (with-fluids ((%active-exception-handlers handlers))
+ (with-fluids ((%active-exception-handlers handlers)
+ ;; Calling raise-exception adds 3 frames to
+ ;; the stack; record this so the handler can
+ ;; determine the correct error location.
+ (%skip-stack-frames (+ 3 skip-frames)))
(cond
(continuable?
(handler exn))
@@ -1761,7 +1772,7 @@ If there is no handler at all, Guile prints an error and
then exits."
(unless (symbol? key)
(throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
(list 1 key) (list key)))
- (raise-exception (make-exception-from-throw key args)))
+ (raise-exception (make-exception-from-throw key args) #:skip-frames 1))
(define (with-throw-handler k thunk pre-unwind-handler)
"Add @var{handler} to the dynamic context as a throw handler
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index c42bd266f..c2fc155c1 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -134,9 +134,9 @@ Once @var{thunk} or @var{handler} returns, the return value
is made the
(lambda () (%start-stack 'thread thunk))
(lambda _ (values))
(lambda (key . args)
- ;; Narrow by three: the dispatch-exception,
- ;; this thunk, and make-stack.
- (let ((stack (make-stack #t 3)))
+ ;; Narrow by two extra frames: this thunk, and make-stack.
+ (let* ((skip (+ 2 (fluid-ref %skip-stack-frames)))
+ (stack (make-stack #t skip)))
(false-if-exception
(begin
(when stack
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index 8d5a8a5f0..f9f8b1416 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -135,9 +135,9 @@
(cdr (fluid-ref %stacks))))
(stack (narrow-stack->vector
(make-stack #t)
- ;; Cut three frames from the top of the stack:
- ;; make-stack, this one, and the throw handler.
- 3
+ ;; Cut two extra frames from the top of the
stack:
+ ;; make-stack, and this one.
+ (+ 2 (fluid-ref %skip-stack-frames))
;; Narrow the end of the stack to the most recent
;; start-stack.
tag
@@ -165,7 +165,9 @@
(frames (narrow-stack->vector
(make-stack #t)
;; Narrow as above, for the debugging case.
- 3 tag 0 (and tag 1))))
+ (+ 2 (fluid-ref %skip-stack-frames))
+ tag
+ 0 (and tag 1))))
(with-saved-ports (lambda () (print-frames frames)))
(report-error key args)
(if #f #f)))))
--
2.37.3
