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