source: trunk/j/src/org/armedbear/lisp/debug.lisp @ 5192

Last change on this file since 5192 was 5192, checked in by piso, 17 years ago

Work in progress.

File size: 2.9 KB
Line 
1;;; debug.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: debug.lisp,v 1.13 2003-12-19 03:24:02 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Adapted from SBCL.
21
22(in-package "EXTENSIONS")
23
24(export '(*debug-condition* *debug-level* show-restarts))
25
26(defvar *debug-condition* nil)
27
28(defvar *debug-level* 0)
29
30(in-package "SYSTEM")
31
32(defun show-restarts (restarts stream)
33  (when restarts
34    (fresh-line stream)
35    (format stream "Restarts:~%")
36    (let ((max-name-len 0))
37      (dolist (restart restarts)
38        (let ((name (restart-name restart)))
39          (when name
40            (let ((len (length (princ-to-string name))))
41              (when (> len max-name-len)
42                (setf max-name-len len))))))
43      (let ((count 0))
44        (dolist (restart restarts)
45          (let ((name (restart-name restart))
46                (report-function (restart-report-function restart)))
47            (%format stream "  ~D: ~A" count name)
48            (when (functionp report-function)
49              (dotimes (i (1+ (- max-name-len (length (princ-to-string name)))))
50                (write-char #\space stream))
51              (funcall report-function stream))
52            (terpri stream))
53          (incf count))))))
54
55(defun debug-loop ()
56  (let ((*debug-level* (1+ *debug-level*)))
57    (show-restarts (compute-restarts) *debug-io*)
58    (loop
59      (tpl::repl))))
60
61(defun invoke-debugger (condition)
62  (when *debugger-hook*
63    (let ((hook-function *debugger-hook*)
64          (*debugger-hook* nil))
65      (funcall hook-function condition hook-function)))
66  (when condition
67    (fresh-line *debug-io*)
68    (%format *debug-io* "Debugger invoked on condition of type ~A:~%" (type-of condition))
69    (%format *debug-io* "  ~A~%" condition))
70  (let ((*debug-condition* condition)
71        (level *debug-level*))
72    (clear-input)
73    (if (> level 0)
74        (with-simple-restart (abort "Return to debug level ~D." level)
75          (debug-loop))
76        (debug-loop))))
77
78(defun break (&optional (format-control "BREAK called") &rest format-arguments)
79  (with-simple-restart (continue "Return from BREAK.")
80    (invoke-debugger
81     (make-condition 'simple-condition
82                     :format-control format-control
83                     :format-arguments format-arguments)))
84  nil)
Note: See TracBrowser for help on using the repository browser.