forked from phoe/trivial-custom-debugger
-
-
Notifications
You must be signed in to change notification settings - Fork 0
/
trivial-custom-debugger.lisp
98 lines (93 loc) · 4.29 KB
/
trivial-custom-debugger.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
;;; BSD 2-Clause License
;;;
;;; Copyright (c) 2020, Michał "phoe" Herda
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions are met:
;;;
;;; 1. Redistributions of source code must retain the above copyright notice,
;;; this list of conditions and the following disclaimer.
;;;
;;; 2. Redistributions in binary form must reproduce the above copyright notice,
;;; this list of conditions and the following disclaimer in the documentation
;;; and/or other materials provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;;; CONTRACT, STRICT LIABILITY,OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;; POSSIBILITY OF SUCH DAMAGE.
(defpackage #:trivial-custom-debugger
(:use #:cl)
(:export #:install-debugger
#:call-with-debugger
#:with-debugger))
(in-package #:trivial-custom-debugger)
(defun install-debugger (hook)
"Sets the provided debugger hook function as the system debugger function."
(assert (functionp hook))
(macrolet ((named-lambda (name (&rest args) &body body)
`(labels ((,name ,args ,@body)) #',name)))
(flet (#-(or clisp allegro lispworks)
(make-hook (hook)
(assert (functionp hook))
(named-lambda invoke-hook (condition old-hook)
(let (*debugger-hook*)
(funcall hook condition old-hook))))
#+clisp
(make-hook (hook)
(named-lambda break-driver (continuable &optional condition print)
(declare (ignore continuable print))
(let (*debugger-hook*)
(funcall hook condition hook))))
#+allegro
(make-hook (hook)
(named-lambda break-hook (&rest args)
(let ((condition (fifth args)))
(funcall hook condition hook))))
#+lispworks
(make-hook (hook)
(list (named-lambda debugger-wrapper (function condition)
(declare (ignore function))
(funcall hook condition hook))))
#+mezzano
(make-hook (hook)
(assert (functionp hook))
(named-lambda invoke-hook (condition)
(let (*debugger-hook*)
(funcall hook condition hook)))))
(setf #+sbcl sb-ext:*invoke-debugger-hook*
#+ccl ccl:*break-hook*
#+ecl ext:*invoke-debugger-hook*
#+clasp ext:*invoke-debugger-hook*
#+abcl sys::*invoke-debugger-hook*
#+clisp sys::*break-driver*
#+allegro excl::*break-hook*
#+lispworks dbg::*debugger-wrapper-list*
#+mezzano mezzano.debug:*global-debugger*
(make-hook hook)))))
(defun call-with-debugger (hook thunk)
"Calls the provided thunk function in the dynamic environment where the
provided hook function is set to be the system debugger."
(let (#+sbcl sb-ext:*invoke-debugger-hook*
#+ccl ccl:*break-hook*
#+ecl ext:*invoke-debugger-hook*
#+clasp ext:*invoke-debugger-hook*
#+abcl sys::*invoke-debugger-hook*
#+clisp sys::*break-driver*
#+allegro excl::*break-hook*
#+lispworks dbg::*debugger-wrapper-list*
#+mezzano mezzano.debug:*global-debugger*)
(install-debugger hook)
(funcall thunk)))
(defmacro with-debugger ((hook) &body body)
"Executes the provided forms in the dynamic environment where the provided
hook function is set to be the system debugger."
`(call-with-debugger ,hook (lambda () ,@body)))