source: trunk/abcl/src/org/armedbear/lisp/debug.lisp @ 14215

Last change on this file since 14215 was 13434, checked in by ehuelsmann, 9 years ago

Correct stream being modified to be *DEBUG-IO* bound streams.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 5.9 KB
Line 
1;;; debug.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: debug.lisp 13434 2011-08-02 20:57:38Z ehuelsmann $
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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Adapted from SBCL.
33
34(in-package #:extensions)
35
36(export '(*debug-condition* *debug-level* show-restarts))
37
38(defvar *debug-condition* nil)
39
40(defvar *debug-level* 0)
41
42(in-package #:system)
43
44(defun show-restarts (restarts stream)
45  (when restarts
46    (fresh-line stream)
47    (%format stream "Restarts:~%")
48    (let ((max-name-len 0))
49      (dolist (restart restarts)
50        (let ((name (restart-name restart)))
51          (when name
52            (let ((len (length (princ-to-string name))))
53              (when (> len max-name-len)
54                (setf max-name-len len))))))
55      (let ((count 0))
56        (dolist (restart restarts)
57          (let ((name (restart-name restart))
58                (report-function (restart-report-function restart)))
59            (%format stream "  ~D: ~A" count name)
60            (when (functionp report-function)
61              (dotimes (i (1+ (- max-name-len (length (princ-to-string name)))))
62                (write-char #\space stream))
63              (funcall report-function stream))
64            (terpri stream))
65          (incf count))))))
66
67(defun internal-debug ()
68  (if (fboundp 'tpl::repl)
69      (let* ((current-debug-io
70              (if (typep *debug-io* 'synonym-stream)
71                  (symbol-value (synonym-stream-symbol *debug-io*))
72                  *debug-io*))
73             (in (two-way-stream-input-stream current-debug-io))
74             (out (two-way-stream-output-stream current-debug-io)))
75        (loop
76          (tpl::repl in out)))
77      (quit)))
78
79(defun debug-loop ()
80  (let ((*debug-level* (1+ *debug-level*)))
81    (show-restarts (compute-restarts) *debug-io*)
82    (internal-debug)))
83
84(defun invoke-debugger-report-condition (condition)
85  (when condition
86    (fresh-line *debug-io*)
87    (with-standard-io-syntax
88      (let ((*print-structure* nil)
89      (*print-readably* nil))
90        (when (and *load-truename* (streamp *load-stream*))
91          (simple-format *debug-io*
92                         "Error loading ~A at line ~D (offset ~D)~%"
93                         *load-truename*
94                         (stream-line-number *load-stream*)
95                         (stream-offset *load-stream*)))
96        (simple-format *debug-io*
97                       (if (fboundp 'tpl::repl)
98                           "~S: Debugger invoked on condition of type ~A~%"
99                           "~S: Unhandled condition of type ~A:~%")
100                       (threads:current-thread)
101                       (type-of condition))
102        (simple-format *debug-io* "  ~A~%" condition)))))
103
104(declaim (inline run-hook))
105(defun run-hook (hook &rest args)
106  (let ((hook-function (symbol-value hook)))
107    (when hook-function
108      (progv (list hook) (list nil)
109        (apply hook-function args)))))
110
111(defvar *invoke-debugger-hook* nil
112  "Like *DEBUGGER-HOOK* but observed by INVOKE-DEBUGGER even when
113called by BREAK. This hook is run before *DEBUGGER-HOOK*.")
114
115;;; We run *INVOKE-DEBUGGER-HOOK* before *DEBUGGER-HOOK* because SBCL
116;;; does so, too, and for good reason: This way, you can specify
117;;; default debugger behaviour that trumps over whatever the users
118;;; wants to do with *DEBUGGER-HOOK*.
119(defun invoke-debugger (condition)
120  (let ((*saved-backtrace* (sys:backtrace)))
121    (run-hook '*invoke-debugger-hook* condition *invoke-debugger-hook*)
122    (run-hook '*debugger-hook*        condition *debugger-hook*)
123    (invoke-debugger-report-condition condition)
124    (unless (fboundp 'tpl::repl)
125      (quit))
126    (let ((original-package *package*))
127      (with-standard-io-syntax
128        (let ((*package* original-package)
129              (*print-readably* nil)    ; Top-level default.
130              (*print-structure* nil)
131              (*debug-condition* condition)
132              (level *debug-level*))
133          (clear-input *debug-io*)
134          (if (> level 0)
135              (with-simple-restart (abort "Return to debug level ~D." level)
136                (debug-loop))
137              (debug-loop)))))))
138
139(defun break (&optional (format-control "BREAK called") &rest format-arguments)
140  (let ((*debugger-hook* nil)) ; Specifically required by ANSI.
141    (with-simple-restart (continue "Return from BREAK.")
142      (invoke-debugger
143       (%make-condition 'simple-condition
144                        (list :format-control format-control
145                              :format-arguments format-arguments))))
146    nil))
147
148(defun backtrace-as-list (&optional (n 0))
149  "Return BACKTRACE with each element converted to a list."
150  (mapcar #'sys::frame-to-list (sys:backtrace n)))
Note: See TracBrowser for help on using the repository browser.