X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Fdebug.lisp;h=76eef9784364f02bef8663baeb7329b4adccb2cf;hb=8a8a8922802460741d6f8f6c11d71b1f414cf3a7;hp=250200b9d9d33e962ee5458829ab000bff31d867;hpb=3e991f3ecd3a0a5ba50bc5b43c4ed0133c837701;p=sbcl.git diff --git a/contrib/sb-aclrepl/debug.lisp b/contrib/sb-aclrepl/debug.lisp index 250200b..76eef97 100644 --- a/contrib/sb-aclrepl/debug.lisp +++ b/contrib/sb-aclrepl/debug.lisp @@ -6,6 +6,75 @@ (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::*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))) + (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)))) + (fresh-line) + ;;(sb-debug::print-frame-call sb-debug::*current-frame* :verbosity 2) + (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)))) + 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*)) @@ -18,96 +87,31 @@ (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) - (debug-loop)) - -(defun continuable-break-p () - (when (eq 'continue - (restart-name (car (compute-restarts)))) - t)) - - -(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*)) + (acldebug-loop)) -(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*)) - (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)))) - (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-debug::debug-prompt *debug-io*) - (force-output *debug-io*) - (let* ((exp (read *debug-io*)) - (cmd-fun (sb-debug::debug-command-p exp restart-commands))) - (cond ((not cmd-fun) - (sb-debug::debug-eval-print exp)) - ((consp cmd-fun) - (format t "~&Your command, ~S, is ambiguous:~%" - exp) - (dolist (ele cmd-fun) - (format t " ~A~%" ele))) - (t - (funcall cmd-fun)))))))))))) #+ignore -(defun debug-loop () +(defun acldebug-loop () (let ((continuable (continuable-break-p))) (if continuable - (aclrepl :continuable t) - (with-simple-restart (abort - "~@" - *break-level*) - (aclrepl))))) + (aclrepl :continuable t) + (let ((level *break-level*)) + (with-simple-restart + (abort "~@" level) + (loop + (repl))))))) -#+ignore -(when (boundp 'sb-debug::*debug-loop-fun*) - (setq sb-debug::*debug-loop-fun* #'debug-loop))