0.8.19.15:

[sbcl.git] / contrib / sb-aclrepl / debug.lisp

diff --git a/contrib/sb-aclrepl/debug.lisp b/contrib/sb-aclrepl/debug.lisp
index 34b8db1..76eef97 100644 (file)
--- a/contrib/sb-aclrepl/debug.lisp
+++ b/contrib/sb-aclrepl/debug.lisp
@@ -6,9 +6,11 @@
 
 (cl:in-package :sb-aclrepl)
 
-
+;;; FIXME: These declaims violate package locks. Are they needed at
+;;; all? Seems not.
+#+ignore
 (declaim (special
-         sb-debug::*debug-command-level sb-debug::*debug-command-level*
+         sb-debug::*debug-command-level*
          sb-debug::*real-stack-top* sb-debug::*stack-top*
          sb-debug::*stack-top-hint* sb-debug::*current-frame*
          sb-debug::*flush-debug-errors*))
@@ -28,28 +30,31 @@
                      (throw 'debug-loop-catcher nil))))
       (fresh-line)
       ;;(sb-debug::print-frame-call sb-debug::*current-frame* :verbosity 2)
-      (loop
-       (catch 'debug-loop-catcher
-         (handler-bind ((error (lambda (condition)
-                                 (when sb-debug::*flush-debug-errors*
-                                   (clear-input *debug-io*)
-                                   (princ condition)
-                                   ;; FIXME: Doing input on *DEBUG-IO*
-                                   ;; and output on T seems broken.
-                                   (format t
-                                           "~&error flushed (because ~
+      (loop ;; only valid to way to exit invoke-debugger is by a restart
+       (catch 'debug-loop-catcher
+        (handler-bind ((error (lambda (condition)
+                                (when sb-debug::*flush-debug-errors*
+                                  (clear-input *debug-io*)
+                                  (princ condition)
+                                  ;; FIXME: Doing input on *DEBUG-IO*
+                                  ;; and output on T seems broken.
+                                  (format t
+                                          "~&error flushed (because ~
                                             ~S is set)"
-                                           'sb-debug::*flush-debug-errors*)
-                                   (sb-int:/show0 "throwing DEBUG-LOOP-CATCHER")
-                                   (throw 'debug-loop-catcher nil)))))
-           ;; We have to bind LEVEL for the restart function created by
-           ;; WITH-SIMPLE-RESTART.
-           (let ((level sb-debug::*debug-command-level*)
-                 (restart-commands (sb-debug::make-restart-commands)))
-             (with-simple-restart (abort
-                                  "~@<Reduce debugger level (to debug level ~W).~@:>"
-                                   level)
-               (sb-impl::repl :continuable continuable)))))))))
+                                         'sb-debug::*flush-debug-errors*)
+                                  (sb-int:/show0 "throwing DEBUG-LOOP-CATCHER")
+                                  (throw 'debug-loop-catcher nil)))))
+          
+          (if (zerop *break-level*) ; restart added by SBCL
+              (repl :continuable continuable)       
+              (let ((level *break-level*))
+                (with-simple-restart
+                    (abort "~@<Reduce debugger level (to break level ~W).~@:>"
+                           level)
+                  (let ((sb-debug::*debug-restarts* (compute-restarts)))
+                    (repl :continuable continuable)))))))
+       (throw 'repl-catcher (values :debug :exit))
+       ))))
 
 
 (defun continuable-break-p ()
@@ -61,7 +66,15 @@
 (when (boundp 'sb-debug::*debug-loop-fun*)
   (setq sb-debug::*debug-loop-fun* #'debug-loop))
 
-#||
+(defun print-restarts ()
+  ;;  (format *output* "~&Restart actions (select using :continue)~%")
+  (format *standard-output* "~&Restart actions (select using :continue)~%")
+  (let ((restarts (compute-restarts)))
+    (dotimes (i (length restarts))
+      (format *standard-output* "~&~2D: ~A~%" i (nth i restarts)))))
+
+
+#+ignore
 (defun debugger (condition)
   "Enter the debugger."
   (let ((old-hook *debugger-hook*))
@@ -74,18 +87,15 @@
 (when (boundp 'sb-debug::*invoke-debugger-fun*)
   (setq sb-debug::*invoke-debugger-fun* #'debugger))
 
+#+ignore
 (defun print-condition (condition)
   (format *output* "~&Error: ~A~%" condition))
 
+#+ignore
 (defun print-condition-type (condition)
   (format *output* "~&  [Condition type: ~A]~%" (type-of condition)))
-
-(defun print-restarts ()
-  (format *output* "~&Restart actions (select using :continue)~%")
-  (let ((restarts (compute-restarts)))
-    (dotimes (i (length restarts))
-      (format *output* "~&~2D: ~A~%" i (nth i restarts)))))
-
+ 
+#+ignore
 (defun %debugger (condition)
   (print-condition condition)
   (print-condition-type condition)
@@ -94,16 +104,14 @@
   (acldebug-loop))
 
 
+#+ignore
 (defun acldebug-loop ()
   (let ((continuable (continuable-break-p)))
     (if continuable
        (aclrepl :continuable t)
-       (let ((level sb-impl::*break-level*))
-         (with-simple-restart (abort
-                               "~@<Reduce debugger level (to debug level ~W).~@:>"
-                               level)
+       (let ((level *break-level*))
+         (with-simple-restart
+             (abort "~@<Reduce debugger level (to debug level ~W).~@:>" level)
            (loop
-            (sb-impl::repl)))))))
-
-||#
+            (repl)))))))