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
  10 (declaim (special
  11           sb-debug::*debug-command-level sb-debug::*debug-command-level*
  12           sb-debug::*real-stack-top* sb-debug::*stack-top*
  13           sb-debug::*stack-top-hint* sb-debug::*current-frame*
  14           sb-debug::*flush-debug-errors*))
  15
  16 (defun debug-loop ()
  17   (let* ((sb-debug::*debug-command-level* (1+ sb-debug::*debug-command-level*))
  18          (sb-debug::*real-stack-top* (sb-di:top-frame))
  19          (sb-debug::*stack-top* (or sb-debug::*stack-top-hint*
  20                                     sb-debug::*real-stack-top*))
  21          (sb-debug::*stack-top-hint* nil)
  22          (sb-debug::*current-frame* sb-debug::*stack-top*)
  23          (continuable (continuable-break-p)))
  24     (handler-bind ((sb-di:debug-condition
  25                     (lambda (condition)
  26                       (princ condition sb-debug::*debug-io*)
  27                       (sb-int:/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
  28                       (throw 'debug-loop-catcher nil))))
  29       (fresh-line)
  30       ;;(sb-debug::print-frame-call sb-debug::*current-frame* :verbosity 2)
  31       (loop
  32         (catch 'debug-loop-catcher
  33           (handler-bind ((error (lambda (condition)
  34                                   (when sb-debug::*flush-debug-errors*
  35                                     (clear-input *debug-io*)
  36                                     (princ condition)
  37                                     ;; FIXME: Doing input on *DEBUG-IO*
  38                                     ;; and output on T seems broken.
  39                                     (format t
  40                                             "~&error flushed (because ~
  41                                              ~S is set)"
  42                                             'sb-debug::*flush-debug-errors*)
  43                                     (sb-int:/show0 "throwing DEBUG-LOOP-CATCHER")
  44                                     (throw 'debug-loop-catcher nil)))))
  45             ;; We have to bind LEVEL for the restart function created by
  46             ;; WITH-SIMPLE-RESTART.
  47             (let ((level sb-debug::*debug-command-level*)
  48                   (restart-commands (sb-debug::make-restart-commands)))
  49               (with-simple-restart (abort
  50                                    "~@<Reduce debugger level (to debug level ~W).~@:>"
  51                                     level)
  52                 (sb-impl::repl :continuable continuable)))))))))
  53
  54
  55 (defun continuable-break-p ()
  56   (when (eq 'continue
  57             (restart-name (car (compute-restarts))))
  58     t))
  59
  60 #+ignore
  61 (when (boundp 'sb-debug::*debug-loop-fun*)
  62   (setq sb-debug::*debug-loop-fun* #'debug-loop))
  63
  64 #||
  65 (defun debugger (condition)
  66   "Enter the debugger."
  67   (let ((old-hook *debugger-hook*))
  68     (when old-hook
  69       (let ((*debugger-hook* nil))
  70         (funcall old-hook condition old-hook))))
  71   (%debugger condition))
  72
  73 #+ignore
  74 (when (boundp 'sb-debug::*invoke-debugger-fun*)
  75   (setq sb-debug::*invoke-debugger-fun* #'debugger))
  76
  77 (defun print-condition (condition)
  78   (format *output* "~&Error: ~A~%" condition))
  79
  80 (defun print-condition-type (condition)
  81   (format *output* "~&  [Condition type: ~A]~%" (type-of condition)))
  82
  83 (defun print-restarts ()
  84   (format *output* "~&Restart actions (select using :continue)~%")
  85   (let ((restarts (compute-restarts)))
  86     (dotimes (i (length restarts))
  87       (format *output* "~&~2D: ~A~%" i (nth i restarts)))))
  88
  89 (defun %debugger (condition)
  90   (print-condition condition)
  91   (print-condition-type condition)
  92   (princ #\newline *output*)
  93   (print-restarts)
  94   (acldebug-loop))
  95
  96
  97 (defun acldebug-loop ()
  98   (let ((continuable (continuable-break-p)))
  99     (if continuable
 100         (aclrepl :continuable t)
 101         (let ((level sb-impl::*break-level*))
 102           (with-simple-restart (abort
 103                                 "~@<Reduce debugger level (to debug level ~W).~@:>"
 104                                 level)
 105             (loop
 106              (sb-impl::repl)))))))
 107
 108 ||#
 109