[4898ef]: contrib / sb-aclrepl / debug.lisp Maximize Restore History

Download this file

debug.lisp    118 lines (100 with data), 4.4 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
;;;; Debugger for sb-aclrepl
;;;;
;;;; The documentation, which may or may not apply in its entirety at
;;;; any given time, for this functionality is on the ACL website:
;;;; <http://www.franz.com/support/documentation/6.2/doc/top-level.htm>.
(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 "~@<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 ()
(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*))
(when old-hook
(let ((*debugger-hook* nil))
(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)))
#+ignore
(defun %debugger (condition)
(print-condition condition)
(print-condition-type condition)
(princ #\newline *output*)
(print-restarts)
(acldebug-loop))
#+ignore
(defun acldebug-loop ()
(let ((continuable (continuable-break-p)))
(if continuable
(aclrepl :continuable t)
(let ((level *break-level*))
(with-simple-restart
(abort "~@<Reduce debugger level (to debug level ~W).~@:>" level)
(loop
(repl)))))))