From 67c4505e7a1002d8bbb395d3d4d79e77250f737e Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sat, 9 Aug 2008 14:30:52 +0200
Subject: [PATCH] backtraces on meta-commands too

* module/system/repl/repl.scm (call-with-backtrace): New helper.
  (start-repl): Use the helper, for normal expressions *and* for
  meta-commands.
---
 module/system/repl/repl.scm | 34 ++++++++++++++++++++--------------
 1 file changed, 20 insertions(+), 14 deletions(-)

diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index e5ed11a15..75a500a72 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -90,6 +90,12 @@
     (else
      (apply bad-throw args))))
 
+(define (call-with-backtrace thunk)
+  (catch #t
+         thunk
+         default-catch-handler
+         default-pre-unwind-handler))
+
 (eval-case
  ((compile-toplevel)
   (define-macro (start-stack tag expr)
@@ -102,23 +108,23 @@
       (let ((exp (prompting-meta-read repl)))
         (cond
          ((eq? exp meta-command-token)
-          (meta-command repl (read-line)))
+          (call-with-backtrace
+           (lambda ()
+             (meta-command repl (read-line)))))
          ((eof-object? exp)
           (throw 'quit))
          (else
-          (catch #t
-                 (lambda ()
-                   (call-with-values (lambda ()
-                                       (run-hook before-eval-hook exp)
-                                       (start-stack repl-eval
-                                                    (repl-eval repl exp)))
-                     (lambda l
-                       (for-each (lambda (v)
-                                   (run-hook before-print-hook v)
-                                   (repl-print repl v))
-                                 l))))
-                 default-catch-handler
-                 default-pre-unwind-handler)))
+          (call-with-backtrace
+           (lambda ()
+             (call-with-values (lambda ()
+                                 (run-hook before-eval-hook exp)
+                                 (start-stack repl-eval
+                                              (repl-eval repl exp)))
+               (lambda l
+                 (for-each (lambda (v)
+                             (run-hook before-print-hook v)
+                             (repl-print repl v))
+                           l)))))))
         (next-char #f) ;; consume trailing whitespace
         (prompt-loop)))))