1 ;;;; This file is for testing the single-stepper.
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
16 #+interpreter
(sb-ext:exit
:code
104)
17 ;; No stepper support on some platforms.
18 #-
(or x86 x86-64 ppc sparc mips arm
)
19 (sb-ext:exit
:code
104)
22 (declare (optimize debug
))
28 (defvar *cerror-called
* nil
)
30 (define-condition cerror-break
(error) ())
33 (declare (optimize debug
))
36 (unless *cerror-called
*
37 (cerror "a" 'cerror-break
)
38 (setf *cerror-called
* t
))
41 (fib-break (- x
2)))))
44 (declare (optimize debug
))
51 (declare (optimize debug
))
54 (defun test-step-into ()
56 ;; The generic-< VOP on x86oids doesn't emit a full call
59 '(("(< X 2)" :unknown
)
69 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)
73 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
))
75 '(("(- X 1)" :unknown
)
81 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)
84 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)))
85 (*stepper-hook
* (lambda (condition)
88 (push (list (step-condition-form condition
)
89 (step-condition-args condition
))
91 (invoke-restart 'step-into
))))))
93 (assert (equal expected
(reverse results
)))))
95 (defun test-step-next ()
99 '(("(< X 2)" :unknown
)
106 ("(FIB (- X 2))" (0))
107 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)
109 ("(FIB (- X 2))" (1))
110 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
))
112 '(("(- X 1)" :unknown
)
117 ("(FIB (- X 2))" (0))
118 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)
120 ("(FIB (- X 2))" (1))
121 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)))
123 (*stepper-hook
* (lambda (condition)
126 (push (list (step-condition-form condition
)
127 (step-condition-args condition
))
129 (if (< (incf count
) 4)
130 (invoke-restart 'step-into
)
131 (invoke-restart 'step-next
)))))))
133 (assert (equal expected
(reverse results
)))))
135 (defun test-step-out ()
139 '(("(< X 2)" :unknown
)
144 ("(FIB (- X 2))" (1))
146 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
))
148 '(("(- X 1)" :unknown
)
153 ("(FIB (- X 2))" (1))
154 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)))
156 (*stepper-hook
* (lambda (condition)
159 (push (list (step-condition-form condition
)
160 (step-condition-args condition
))
162 (if (= (incf count
) 4)
163 (invoke-restart 'step-out
)
164 (invoke-restart 'step-into
)))))))
166 (assert (equal expected
(reverse results
)))))
168 (defun test-step-start-from-break ()
172 '(("(- X 2)" :unknown
)
173 ("(FIB-BREAK (- X 2))" (0))
175 ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown
)
177 ("(FIB-BREAK (- X 2))" (1))
179 ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown
))
181 '(("(- X 2)" :unknown
)
182 ("(FIB-BREAK (- X 2))" (0))
183 ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown
)
185 ("(FIB-BREAK (- X 2))" (1))
186 ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown
)))
187 (*stepper-hook
* (lambda (condition)
190 (push (list (step-condition-form condition
)
191 (step-condition-args condition
))
193 (invoke-restart 'step-into
))))))
194 (setf *cerror-called
* nil
)
195 (handler-bind ((cerror-break
198 (sb-impl::enable-stepping
)
199 (invoke-restart 'continue
))))
201 (assert (equal expected
(reverse results
)))))
203 (defun test-step-frame ()
205 (*stepper-hook
* (lambda (condition)
208 (let* ((frame (sb-di::find-stepped-frame
))
209 (dfun (sb-di::frame-debug-fun frame
))
210 (name (sb-di::debug-fun-name dfun
)))
211 (assert (equal name
'fib
))
213 (invoke-restart 'step-next
)))))))
215 (assert (= count
#-
(or x86 x86-64
) 6 #+(or x86 x86-64
) 5))))
217 (defun test-step-backtrace ()
218 (let* ((*stepper-hook
* (lambda (condition)
221 (let ((*debug-io
* (make-broadcast-stream)))
222 (print-backtrace)))))))
225 (defun test-step-next/2 ()
227 (expected '(("(IN)" ())
233 (*stepper-hook
* (lambda (condition)
236 (push (list (step-condition-form condition
)
237 (step-condition-args condition
))
239 (if (>= (incf count
) 3)
240 (invoke-restart 'step-into
)
241 (invoke-restart 'step-into
)))))))
243 (assert (equal expected
(reverse results
)))))
245 (defun test-step-out/2 ()
247 (expected '(("(IN)" ())
251 (*stepper-hook
* (lambda (condition)
254 (push (list (step-condition-form condition
)
255 (step-condition-args condition
))
257 (if (>= (incf count
) 3)
258 (invoke-restart 'step-out
)
259 (invoke-restart 'step-into
)))))))
261 (assert (equal expected
(reverse results
)))))
263 (with-test (:name
:step-into
)
264 (handler-bind ((step-condition #'sb-impl
::invoke-stepper
))
267 (with-test (:name
:step-next
)
268 (handler-bind ((step-condition #'sb-impl
::invoke-stepper
))
271 (with-test (:name
:step-out
)
272 (handler-bind ((step-condition #'sb-impl
::invoke-stepper
))
275 (with-test (:name
:step-start-from-break
)
276 (handler-bind ((step-condition #'sb-impl
::invoke-stepper
))
277 (test-step-start-from-break)))
279 (with-test (:name
:step-frame
)
280 (handler-bind ((step-condition #'sb-impl
::invoke-stepper
))
283 (with-test (:name
:step-backtrace
)
284 (handler-bind ((step-condition #'sb-impl
::invoke-stepper
))
285 (test-step-backtrace)))
287 (with-test (:name
:step-next
/2)
288 (handler-bind ((step-condition #'sb-impl
::invoke-stepper
))
291 (with-test (:name
:step-out
/2)
292 (handler-bind ((step-condition #'sb-impl
::invoke-stepper
))