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 ;; No stepper support on some platforms.
18 (sb-ext:quit
:unix-status
104)
21 (declare (optimize debug
))
27 (defvar *cerror-called
* nil
)
30 (declare (optimize debug
))
33 (unless *cerror-called
*
35 (setf *cerror-called
* t
))
38 (fib-break (- x
2)))))
40 (defun test-step-into ()
42 (expected '(("(< X 2)" :unknown
)
52 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)
56 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)))
57 (*stepper-hook
* (lambda (condition)
60 (push (list (step-condition-form condition
)
61 (step-condition-args condition
))
63 (invoke-restart 'step-into
))))))
65 (assert (equal expected
(reverse results
)))))
67 (defun test-step-next ()
69 (expected '(("(< X 2)" :unknown
)
77 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)
80 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)))
82 (*stepper-hook
* (lambda (condition)
85 (push (list (step-condition-form condition
)
86 (step-condition-args condition
))
88 (if (< (incf count
) 4)
89 (invoke-restart 'step-into
)
90 (invoke-restart 'step-next
)))))))
92 (assert (equal expected
(reverse results
)))))
94 (defun test-step-out ()
96 (expected '(("(< X 2)" :unknown
)
101 ("(FIB (- X 2))" (1))
103 ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown
)))
105 (*stepper-hook
* (lambda (condition)
108 (push (list (step-condition-form condition
)
109 (step-condition-args condition
))
111 (if (= (incf count
) 4)
112 (invoke-restart 'step-out
)
113 (invoke-restart 'step-into
)))))))
115 (assert (equal expected
(reverse results
)))))
117 (defun test-step-start-from-break ()
119 (expected '(("(- X 2)" :unknown
)
120 ("(FIB-BREAK (- X 2))" (0))
122 ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown
)
124 ("(FIB-BREAK (- X 2))" (1))
126 ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown
)))
128 (*stepper-hook
* (lambda (condition)
131 (push (list (step-condition-form condition
)
132 (step-condition-args condition
))
134 (invoke-restart 'step-into
))))))
135 (setf *cerror-called
* nil
)
136 (handler-bind ((error
138 (sb-impl::enable-stepping
)
139 (invoke-restart 'continue
))))
141 (assert (equal expected
(reverse results
)))))
143 (defun test-step-frame ()
145 (*stepper-hook
* (lambda (condition)
148 (let* ((frame (sb-di::find-stepped-frame
))
149 (dfun (sb-di::frame-debug-fun frame
))
150 (name (sb-di::debug-fun-name dfun
)))
151 (assert (equal name
'fib
))
153 (invoke-restart 'step-next
)))))))
155 (assert (= count
6))))
157 (defun test-step-backtrace ()
158 (let* ((*stepper-hook
* (lambda (condition)
161 (let ((*debug-io
* (make-broadcast-stream)))
165 (with-test (:name
:step-into
)
166 (handler-bind ((step-condition (lambda (c)
167 (funcall *stepper-hook
* c
))))
170 (with-test (:name
:step-next
)
171 (handler-bind ((step-condition (lambda (c)
172 (funcall *stepper-hook
* c
))))
175 (with-test (:name
:step-out
)
176 (handler-bind ((step-condition (lambda (c)
177 (funcall *stepper-hook
* c
))))
180 (with-test (:name
:step-start-from-break
)
181 (handler-bind ((step-condition (lambda (c)
182 (funcall *stepper-hook
* c
))))
183 (test-step-start-from-break)))
185 (with-test (:name
:step-frame
)
186 (handler-bind ((step-condition (lambda (c)
187 (funcall *stepper-hook
* c
))))
190 (with-test (:name
:step-backtrace
)
191 (handler-bind ((step-condition (lambda (c)
192 (funcall *stepper-hook
* c
))))
193 (test-step-backtrace)))