contrib/sb-aclrepl/debug.lisp

   1 ;;;; Debugger for sb-aclrepl
   2 ;;;;
   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>.
   6
   7 (cl:in-package :sb-aclrepl)
   8
   9 (defun debugger (condition)
  10   "Enter the debugger."
  11   (let ((old-hook *debugger-hook*))
  12     (when old-hook
  13       (let ((*debugger-hook* nil))
  14         (funcall old-hook condition old-hook))))
  15   (%debugger condition))
  16
  17 #+ignore
  18 (when (boundp 'sb-debug::*invoke-debugger-fun*)
  19   (setq sb-debug::*invoke-debugger-fun* #'debugger))
  20
  21 (defun print-condition (condition)
  22   (format *output* "~&Error: ~A~%" condition))
  23
  24 (defun print-condition-type (condition)
  25   (format *output* "~&  [Condition type: ~A]~%" (type-of condition)))
  26
  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)))))
  32
  33 (defun %debugger (condition)
  34   (print-condition condition)
  35   (print-condition-type condition)
  36   (princ #\newline *output*)
  37   (print-restarts)
  38   (debug-loop))
  39
  40 (defun continuable-break-p ()
  41   (when (eq 'continue
  42             (restart-name (car (compute-restarts))))
  43     t))
  44
  45
  46 (declaim (special
  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*))
  51
  52 (defun debug-loop ()
  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
  60                     (lambda (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))))
  64       (fresh-line)
  65       (sb-debug::print-frame-call sb-debug::*current-frame* :verbosity 2)
  66       (loop
  67         (catch 'debug-loop-catcher
  68           (handler-bind ((error (lambda (condition)
  69                                   (when sb-debug::*flush-debug-errors*
  70                                     (clear-input *debug-io*)
  71                                     (princ condition)
  72                                     ;; FIXME: Doing input on *DEBUG-IO*
  73                                     ;; and output on T seems broken.
  74                                     (format t
  75                                             "~&error flushed (because ~
  76                                              ~S is set)"
  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).~@:>"
  86                                     level)
  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)))
  91                   (cond ((not cmd-fun)
  92                          (sb-debug::debug-eval-print exp))
  93                         ((consp cmd-fun)
  94                          (format t "~&Your command, ~S, is ambiguous:~%"
  95                                  exp)
  96                          (dolist (ele cmd-fun)
  97                            (format t "   ~A~%" ele)))
  98                         (t
  99                          (funcall cmd-fun))))))))))))
 100
 101 #+ignore
 102 (defun debug-loop ()
 103   (let ((continuable (continuable-break-p)))
 104     (if continuable
 105       (aclrepl :continuable t)
 106       (with-simple-restart (abort
 107                             "~@<Reduce debugger level (to debug level ~W).~@:>"
 108                             *break-level*)
 109         (aclrepl)))))
 110
 111 #+ignore
 112 (when (boundp 'sb-debug::*debug-loop-fun*)
 113   (setq sb-debug::*debug-loop-fun* #'debug-loop))