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

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

2005

File size: 4.6 KB
Line 
1;;; debug.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: debug.lisp,v 1.30 2005-01-24 19:17:41 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 internal-debug ()
56  (if (fboundp 'tpl::repl)
57      (let* ((current-debug-io
58              (if (typep *debug-io* 'synonym-stream)
59                  (symbol-value (synonym-stream-symbol *debug-io*))
60                  *debug-io*))
61             (in (two-way-stream-input-stream current-debug-io))
62             (out (two-way-stream-output-stream current-debug-io)))
63        (loop
64          (tpl::repl in out)))
65      (quit)))
66
67(defun debug-loop ()
68  (let ((*debug-level* (1+ *debug-level*)))
69    (show-restarts (compute-restarts) *debug-io*)
70    (internal-debug)))
71
72(defun invoke-debugger-report-condition (condition)
73  (when condition
74    (fresh-line *debug-io*)
75    (let* ((type (type-of condition))
76           (report-function (get type 'sys::condition-report-function)))
77      (with-standard-io-syntax
78        (when (and *load-truename* (streamp *load-stream*))
79          (sys:simple-format *debug-io*
80                             "Error loading ~A at line ~D (offset ~D).~%"
81                             *load-truename*
82                             (stream-line-number *load-stream*)
83                             (stream-offset *load-stream*)))
84        (sys:simple-format *debug-io*
85                           (if (fboundp 'tpl::repl)
86                               "Debugger invoked on condition of type ~A:~%"
87                               "Unhandled condition of type ~A:~%")
88                           type)
89        (if report-function
90            (funcall report-function condition *debug-io*)
91            (sys:simple-format *debug-io* "  ~A~%" condition))))))
92
93(defun invoke-debugger (condition)
94  (when *debugger-hook*
95    (let ((hook-function *debugger-hook*)
96          (*debugger-hook* nil))
97      (funcall hook-function condition hook-function)))
98  (invoke-debugger-report-condition condition)
99  (unless (fboundp 'tpl::repl)
100    (quit))
101  (let ((original-package *package*))
102    (with-standard-io-syntax
103      (let ((*package* original-package)
104            (*print-readably* nil) ;; Top-level default.
105            (*debug-condition* condition)
106            (level *debug-level*))
107        (clear-input)
108        (if (> level 0)
109            (with-simple-restart (abort "Return to debug level ~D." level)
110              (debug-loop))
111            (debug-loop))))))
112
113(defun break (&optional (format-control "BREAK called") &rest format-arguments)
114  (let ((*debugger-hook* nil) ; Specifically required by ANSI.
115        (*saved-backtrace* (backtrace-as-list)))
116    (with-simple-restart (continue "Return from BREAK.")
117      (invoke-debugger
118       (%make-condition 'simple-condition
119                        (list :format-control format-control
120                              :format-arguments format-arguments))))
121    nil))
Note: See TracBrowser for help on using the repository browser.