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

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

INTERNAL-DEBUG: *DEBUG-IO* might be a synonym stream.

File size: 4.3 KB
Line 
1;;; debug.lisp
2;;;
3;;; Copyright (C) 2003-2004 Peter Graves
4;;; $Id: debug.lisp,v 1.28 2004-10-01 13:12:17 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    (with-standard-io-syntax
76      (when (and *load-truename* (streamp *load-stream*))
77        (sys:simple-format *debug-io*
78                           "Error loading ~A at line ~D (offset ~D).~%"
79                           *load-truename*
80                           (stream-line-number *load-stream*)
81                           (stream-offset *load-stream*)))
82      (sys:simple-format *debug-io*
83                         (if (fboundp 'tpl::repl)
84                             "Debugger invoked on condition of type ~A:~%"
85                             "Unhandled condition of type ~A:~%")
86                         (type-of condition))
87      (sys:simple-format *debug-io* "  ~A~%" condition))))
88
89(defun invoke-debugger (condition)
90  (when *debugger-hook*
91    (let ((hook-function *debugger-hook*)
92          (*debugger-hook* nil))
93      (funcall hook-function condition hook-function)))
94  (invoke-debugger-report-condition condition)
95  (unless (fboundp 'tpl::repl)
96    (quit))
97  (let ((original-package *package*))
98    (with-standard-io-syntax
99      (let ((*package* original-package)
100            (*print-readably* nil) ;; Top-level default.
101            (*debug-condition* condition)
102            (level *debug-level*))
103        (clear-input)
104        (if (> level 0)
105            (with-simple-restart (abort "Return to debug level ~D." level)
106              (debug-loop))
107            (debug-loop))))))
108
109(defun break (&optional (format-control "BREAK called") &rest format-arguments)
110  (let ((*debugger-hook* nil) ; Specifically required by ANSI.
111        (*saved-backtrace* (backtrace-as-list)))
112    (with-simple-restart (continue "Return from BREAK.")
113      (invoke-debugger
114       (%make-condition 'simple-condition
115                        (list :format-control format-control
116                              :format-arguments format-arguments))))
117    nil))
Note: See TracBrowser for help on using the repository browser.