1 ;;;; This file is for testing UNWIND-TO-FRAME-AND-CALL, used for
2 ;;;; implementing RESTART-FRAME and RETURN-FROM-FRAME in the debugger.
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; While most of SBCL is derived from the CMU CL system, the test
8 ;;;; files (like this one) were written from scratch after the fork
11 ;;;; This software is in the public domain and is provided with
12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
13 ;;;; more information.
15 ;;; The debugger doesn't have any native knowledge of the interpreter
16 (when (eq sb-ext:*evaluator-mode* :interpret)
17 (sb-ext:exit :code 104))
19 (declaim (optimize debug))
21 (defun return-from-frame (frame-name &rest values)
22 (let ((frame (sb-di::top-frame)))
23 (loop until (equal frame-name
24 (sb-debug::frame-call frame))
25 do (setf frame (sb-di::frame-down frame)))
27 (assert (sb-debug::frame-has-debug-tag-p frame))
28 (sb-debug::unwind-to-frame-and-call frame
30 (values-list values)))))
32 (defun restart-frame (frame-name)
33 (let ((frame (sb-di::top-frame)))
34 (loop until (equal (sb-debug::frame-call frame)
36 do (setf frame (sb-di::frame-down frame)))
38 (assert (sb-debug::frame-has-debug-tag-p frame))
39 (let* ((call-list (sb-debug::frame-call-as-list frame))
40 (fun (fdefinition (car call-list))))
41 (sb-debug::unwind-to-frame-and-call frame
43 (apply fun (cdr call-list)))))))
51 ;;;; Test RESTART-FRAME
53 (define-condition restart-condition () ())
57 (defun restart/special (*foo*)
61 (signal 'restart-condition))
64 (defun restart/optional-special (&optional (*foo* 1))
68 (signal 'restart-condition))
71 (defun restart/normal (foo)
75 (signal 'restart-condition))
80 ;; these tests currently fail no matter whether threads are enabled or
81 ;; not, but on threaded builds the failure mode is particularly
82 ;; unfortunate. As a workaround, opt out of running the test.
84 (error "this test fails with exception 0xc0000029 ~
85 (STATUS_INVALID_UNWIND_TARGET), from which we cannot currently ~
88 (defun test-restart (name)
94 (handler-bind ((restart-condition (lambda (c)
96 (restart-frame name))))
97 (assert (eql (funcall name 1) 1))
98 (assert (eql *count* 2))))
99 ;; Check that the binding stack was correctly unwound.
100 (assert (eql *foo* 'x))))
102 (with-test (:name (:restart-frame :special) :fails-on :win32)
103 (test-restart 'restart/special))
105 (with-test (:name (:restart-frame :optional-special) :fails-on :win32)
106 (test-restart 'restart/optional-special))
108 (with-test (:name (:restart-frame :normal) :fails-on :win32)
109 (test-restart 'restart/normal))
112 ;;;; Test RETURN-FROM-FRAME with normal functions
114 (define-condition return-condition () ())
116 (defun return/special (*foo*)
119 (signal 'return-condition))
122 (defun return/optional-special (&optional (*foo* 1))
125 (signal 'return-condition))
128 (defun return/normal (foo)
131 (signal 'return-condition))
135 (signal 'return-condition))
137 (defun return/catch (foo)
142 (defun test-return (name)
147 (handler-bind ((return-condition (lambda (c)
149 (return-from-frame name 1 2 3 4))))
150 (assert (equal (multiple-value-list (funcall name 0))
152 ;; Check that the binding stack was correctly unwound.
153 (assert (eql *foo* 'x))))
155 (with-test (:name (:return-from-frame :special) :fails-on :win32)
156 (test-return 'return/special))
158 (with-test (:name (:return-from-frame :optional-special) :fails-on :win32)
159 (test-return 'return/optional-special))
161 (with-test (:name (:return-from-frame :normal) :fails-on :win32)
162 (test-return 'return/normal))
164 (defun throw-y () (throw 'y 'y))
166 ;; Check that *CURRENT-CATCH-BLOCK* was correctly restored.
167 (with-test (:name :current-catch-block-restored :fails-on :win32)
168 (assert (eql (catch 'y
169 (test-return 'return/catch)
174 ;;;; Test RETURN-FROM-FRAME with local functions
176 (define-condition in-a () ())
177 (define-condition in-b () ())
186 (setf *a* (multiple-value-list (a)))
187 (setf *b* (multiple-value-list (b)))))
189 (defun hairy-locals ()
191 (flet ((a (&optional *c*)
197 ;; Ensure that A and B actually appear in the backtrace; the
198 ;; compiler for some reason likes to optimize away single-use
199 ;; local functions with hairy lambda-lists even on high debug
202 (setf *b* (b :*c* :good))
204 (setf *a* (multiple-value-list (a :good)))
205 (setf *b* (multiple-value-list (b :*c* :good))))))
207 (defun test-locals (name)
209 (handler-bind ((in-a (lambda (c)
211 (return-from-frame `(flet a :in ,name) 'x 'y)))
214 (return-from-frame `(flet b :in ,name) 'z))))
216 ;; We're intentionally not testing for returning a different amount
217 ;; of values than the local functions are normally returning. It's
218 ;; hard to think of practical cases where that'd be useful, but
219 ;; allowing it (as in the old fully CATCH-based implementation of
220 ;; UNWIND-TO-FRAME-AND-CALL) will make it harder for the compiler to
224 (assert (equal *a* '(x y)))
225 (assert (equal *b* '(z))))
226 (assert (eql *foo* 'x))))
228 (with-test (:name (:return-from-frame :local-function) :fails-on :win32)
229 (test-locals 'locals))
231 (with-test (:name (:return-from-frame :hairy-local-function) :fails-on :win32)
232 (test-locals 'hairy-locals))
235 ;;;; Test RETURN-FROM-FRAME with anonymous functions
237 (define-condition anon-condition () ())
239 (defparameter *anon-1*
241 (signal 'anon-condition)
244 (defparameter *anon-2*
246 (signal 'anon-condition)
249 (defun make-anon-3 ()
250 (let ((a (lambda (foo)
251 (signal 'anon-condition)
256 (defun make-anon-4 ()
257 (let ((a (lambda (*foo*)
258 (signal 'anon-condition)
263 (defparameter *anon-3* (make-anon-3))
264 (defparameter *anon-4* (make-anon-4))
266 (defun test-anon (fun var-name &optional in)
268 (handler-bind ((anon-condition (lambda (c)
271 `(lambda (,var-name) ,@(when in `(:in ,in)))
275 (assert (equal (multiple-value-list (funcall fun 1))
277 (assert (eql *foo* 'y)))
278 (assert (eql *foo* 'x)))))
280 (with-test (:name (:return-from-frame :anonymous :toplevel) :fails-on :win32)
281 (test-anon *anon-1* 'foo (namestring *load-truename*)))
283 (with-test (:name (:return-from-frame :anonymous :toplevel-special)
285 (test-anon *anon-2* '*foo* (namestring *load-truename*)))
287 (with-test (:name (:return-from-frame :anonymous) :fails-on :win32)
288 (test-anon *anon-3* 'foo 'make-anon-3))
290 (with-test (:name (:return-from-frame :anonymous :special) :fails-on :win32)
291 (test-anon *anon-4* '*foo* 'make-anon-4))
294 ;;;; Test that unwind cleanups are executed
296 (defvar *unwind-state* nil)
297 (defvar *signal* nil)
302 (signal 'return-condition))
303 (push :unwind-1 *unwind-state*)))
308 (push :unwind-2 *unwind-state*)))
310 (defun test-unwind (fun wanted)
312 (handler-bind ((return-condition (lambda (c)
314 (return-from-frame fun
316 (dolist (*signal* (list nil t))
318 (*unwind-state* nil))
321 (assert (equal (multiple-value-list (funcall fun))
324 (assert (equal *unwind-state* wanted))
325 (assert (eql *foo* 'y)))
326 (assert (eql *foo* 'x))))))
328 (with-test (:name :test-unwind-1 :fails-on :win32)
329 (test-unwind 'unwind-1 '(:unwind-1)))
330 (with-test (:name :test-unwind-2 :fails-on :win32)
331 (test-unwind 'unwind-2 '(:unwind-2 :unwind-1)))
333 ;;; Regression in 1.0.10.47 reported by James Knight
338 (declaim (inline inline-fun))
339 (defun inline-fun (tla)
343 (defun foo (predicate)
344 (funcall predicate 2))
347 (let ((blah (foo #'inline-fun)))
350 (with-test (:name (:debug-instrumentation :inline/xep))