From 867961f9798d2d6ce398e2d14f8a9dc01cf20ae7 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 15 Jul 2010 12:13:15 +0200
Subject: pass a frame to display-error in system repl error-handling

* module/system/repl/error-handling.scm (call-with-error-handling): Pass
  a frame to display-error.
---
 module/system/repl/error-handling.scm | 42 +++++++++++++++++------------------
 1 file changed, 20 insertions(+), 22 deletions(-)

diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index 28b542830..53af62ed0 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -75,34 +75,32 @@
       (case on-error
         ((debug)
          (lambda (key . args)
-           (let ((stack (make-stack #t)))
+           (let* ((tag (and (pair? (fluid-ref %stacks))
+                            (cdar (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 
+                          ;; Narrow the end of the stack to the most recent
+                          ;; start-stack.
+                          tag
+                          ;; And one more frame, because %start-stack invoking
+                          ;; the start-stack thunk has its own frame too.
+                          0 (and tag 1)))
+                  (debug (make-debug stack 0)))
              (with-saved-ports
               (lambda ()
                 (pmatch args
                   ((,subr ,msg ,args . ,rest)
-                   (format #t "Throw to key `~a':\n" key)
-                   (display-error stack (current-output-port) subr msg args rest))
+                   (display-error (vector-ref stack 0) (current-output-port)
+                                  subr msg args rest))
                   (else
                    (format #t "Throw to key `~a' with args `~s'." key args)))
-                (format #t "Entering a new prompt. Type `,bt' for a backtrace")
-                (format #t " or `,q' to return to the old prompt.\n")
-                (let ((debug
-                       (make-debug
-                        (let ((tag (and (pair? (fluid-ref %stacks))
-                                        (cdar (fluid-ref %stacks)))))
-                          (narrow-stack->vector
-                           stack
-                           ;; Cut three frames from the top of the stack:
-                           ;; make-stack, this one, and the throw handler.
-                           3 
-                           ;; Narrow the end of the stack to the most recent
-                           ;; start-stack.
-                           tag
-                           ;; And one more frame, because %start-stack invoking
-                           ;; the start-stack thunk has its own frame too.
-                           0 (and tag 1)))
-                        0)))
-                  ((@ (system repl repl) start-repl) #:debug debug)))))))
+                (newline)
+                (format #t "Entering a new prompt.  ")
+                (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
+                ((@ (system repl repl) start-repl) #:debug debug))))))
         ((pass)
          (lambda (key . args)
            ;; fall through to rethrow
-- 
cgit v1.2.1