X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Fdebug.lisp;h=c42cff1cfb3f3e9e95b79f7f0833e289504a370f;hb=6a55e39bd39283f56e197cc8719035a9bdd93987;hp=34b8db12286aaecd5aac52a2f15212efd4269ef7;hpb=f06a378c741965a906b6a042c9420efb9c51198f;p=sbcl.git diff --git a/contrib/sb-aclrepl/debug.lisp b/contrib/sb-aclrepl/debug.lisp index 34b8db1..c42cff1 100644 --- a/contrib/sb-aclrepl/debug.lisp +++ b/contrib/sb-aclrepl/debug.lisp @@ -6,104 +6,112 @@ (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::*real-stack-top* sb-debug::*stack-top* - sb-debug::*stack-top-hint* sb-debug::*current-frame* - sb-debug::*flush-debug-errors*)) + 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*)) (defun debug-loop () (let* ((sb-debug::*debug-command-level* (1+ sb-debug::*debug-command-level*)) - (sb-debug::*real-stack-top* (sb-di:top-frame)) - (sb-debug::*stack-top* (or sb-debug::*stack-top-hint* - sb-debug::*real-stack-top*)) - (sb-debug::*stack-top-hint* nil) - (sb-debug::*current-frame* sb-debug::*stack-top*) - (continuable (continuable-break-p))) + (sb-debug::*real-stack-top* (sb-di:top-frame)) + (sb-debug::*stack-top* (or sb-debug::*stack-top-hint* + sb-debug::*real-stack-top*)) + (sb-debug::*stack-top-hint* nil) + (sb-debug::*current-frame* sb-debug::*stack-top*) + (continuable (continuable-break-p))) (handler-bind ((sb-di:debug-condition - (lambda (condition) - (princ condition sb-debug::*debug-io*) - (sb-int:/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil)))) + (lambda (condition) + (princ condition sb-debug::*debug-io*) + (sb-int:/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") + (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 ~ - ~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 - "~@" - level) - (sb-impl::repl :continuable continuable))))))))) + (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))))) + + (if (zerop *break-level*) ; restart added by SBCL + (repl :continuable continuable) + (let ((level *break-level*)) + (with-simple-restart + (abort "~@" + level) + (let ((sb-debug::*debug-restarts* (compute-restarts))) + (repl :continuable continuable))))))) + (throw 'repl-catcher (values :debug :exit)) + )))) (defun continuable-break-p () (when (eq 'continue - (restart-name (car (compute-restarts)))) + (restart-name (car (compute-restarts)))) t)) #+ignore (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*)) (when old-hook (let ((*debugger-hook* nil)) - (funcall old-hook condition old-hook)))) + (funcall old-hook condition old-hook)))) (%debugger condition)) #+ignore (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) (princ #\newline *output*) - (print-restarts) + (print-restarts) (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 - "~@" - level) - (loop - (sb-impl::repl))))))) - -||# + (aclrepl :continuable t) + (let ((level *break-level*)) + (with-simple-restart + (abort "~@" level) + (loop + (repl)))))))