X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Fdebug.lisp;h=2b8787ae95c464c26bf56d2a6c47655bb47f9673;hb=1b650be8b800cf96e2c268ae317fb26d0bf36827;hp=34b8db12286aaecd5aac52a2f15212efd4269ef7;hpb=f06a378c741965a906b6a042c9420efb9c51198f;p=sbcl.git

diff --git a/contrib/sb-aclrepl/debug.lisp b/contrib/sb-aclrepl/debug.lisp
index 34b8db1..2b8787a 100644
--- a/contrib/sb-aclrepl/debug.lisp
+++ b/contrib/sb-aclrepl/debug.lisp
@@ -28,28 +28,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 +64,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 +85,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 +102,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)))))))