1 ;;;; Debugger for sb-aclrepl
3 ;;;; The documentation, which may or may not apply in its entirety at
4 ;;;; any given time, for this functionality is on the ACL website:
5 ;;;; <http://www.franz.com/support/documentation/6.2/doc/top-level.htm>.
7 (cl:in-package :sb-aclrepl)
9 (defun debugger (condition)
11 (let ((old-hook *debugger-hook*))
13 (let ((*debugger-hook* nil))
14 (funcall old-hook condition old-hook))))
15 (%debugger condition))
18 (when (boundp 'sb-debug::*invoke-debugger-fun*)
19 (setq sb-debug::*invoke-debugger-fun* #'debugger))
21 (defun print-condition (condition)
22 (format *output* "~&Error: ~A~%" condition))
24 (defun print-condition-type (condition)
25 (format *output* "~& [Condition type: ~A]~%" (type-of condition)))
27 (defun print-restarts ()
28 (format *output* "~&Restart actions (select using :continue)~%")
29 (let ((restarts (compute-restarts)))
30 (dotimes (i (length restarts))
31 (format *output* "~&~2D: ~A~%" i (nth i restarts)))))
33 (defun %debugger (condition)
34 (print-condition condition)
35 (print-condition-type condition)
36 (princ #\newline *output*)
40 (defun continuable-break-p ()
42 (restart-name (car (compute-restarts))))
47 sb-debug::*debug-command-level sb-debug::*debug-command-level*
48 sb-debug::*real-stack-top* sb-debug::*stack-top*
49 sb-debug::*stack-top-hint* sb-debug::*current-frame*
50 sb-debug::*flush-debug-errors*))
53 (let* ((sb-debug::*debug-command-level* (1+ sb-debug::*debug-command-level*))
54 (sb-debug::*real-stack-top* (sb-di:top-frame))
55 (sb-debug::*stack-top* (or sb-debug::*stack-top-hint*
56 sb-debug::*real-stack-top*))
57 (sb-debug::*stack-top-hint* nil)
58 (sb-debug::*current-frame* sb-debug::*stack-top*))
59 (handler-bind ((sb-di:debug-condition
61 (princ condition sb-debug::*debug-io*)
62 (sb-int:/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
63 (throw 'debug-loop-catcher nil))))
65 (sb-debug::print-frame-call sb-debug::*current-frame* :verbosity 2)
67 (catch 'debug-loop-catcher
68 (handler-bind ((error (lambda (condition)
69 (when sb-debug::*flush-debug-errors*
70 (clear-input *debug-io*)
72 ;; FIXME: Doing input on *DEBUG-IO*
73 ;; and output on T seems broken.
75 "~&error flushed (because ~
77 'sb-debug::*flush-debug-errors*)
78 (sb-int:/show0 "throwing DEBUG-LOOP-CATCHER")
79 (throw 'debug-loop-catcher nil)))))
80 ;; We have to bind LEVEL for the restart function created by
81 ;; WITH-SIMPLE-RESTART.
82 (let ((level sb-debug::*debug-command-level*)
83 (restart-commands (sb-debug::make-restart-commands)))
84 (with-simple-restart (abort
85 "~@<Reduce debugger level (to debug level ~W).~@:>"
87 (sb-debug::debug-prompt *debug-io*)
88 (force-output *debug-io*)
89 (let* ((exp (read *debug-io*))
90 (cmd-fun (sb-debug::debug-command-p exp restart-commands)))
92 (sb-debug::debug-eval-print exp))
94 (format t "~&Your command, ~S, is ambiguous:~%"
97 (format t " ~A~%" ele)))
99 (funcall cmd-fun))))))))))))
103 (let ((continuable (continuable-break-p)))
105 (aclrepl :continuable t)
106 (with-simple-restart (abort
107 "~@<Reduce debugger level (to debug level ~W).~@:>"
112 (when (boundp 'sb-debug::*debug-loop-fun*)
113 (setq sb-debug::*debug-loop-fun* #'debug-loop))