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:quit :unix-status 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))
78 (defun test-restart (name)
83 (handler-bind ((restart-condition (lambda (c)
85 (restart-frame name))))
86 (assert (eql (funcall name 1) 1))
87 (assert (eql *count* 2))))
88 ;; Check that the binding stack was correctly unwound.
89 (assert (eql *foo* 'x))))
91 (with-test (:name (:restart-frame :special))
92 (test-restart 'restart/special))
94 (with-test (:name (:restart-frame :optional-special))
95 (test-restart 'restart/optional-special))
97 (with-test (:name (:restart-frame :normal))
98 (test-restart 'restart/normal))
101 ;;;; Test RETURN-FROM-FRAME with normal functions
103 (define-condition return-condition () ())
105 (defun return/special (*foo*)
108 (signal 'return-condition))
111 (defun return/optional-special (&optional (*foo* 1))
114 (signal 'return-condition))
117 (defun return/normal (foo)
120 (signal 'return-condition))
124 (signal 'return-condition))
126 (defun return/catch (foo)
131 (defun test-return (name)
135 (handler-bind ((return-condition (lambda (c)
137 (return-from-frame name 1 2 3 4))))
138 (assert (equal (multiple-value-list (funcall name 0))
140 ;; Check that the binding stack was correctly unwound.
141 (assert (eql *foo* 'x))))
143 (with-test (:name (:return-from-frame :special))
144 (test-return 'return/special))
146 (with-test (:name (:return-from-frame :optional-special))
147 (test-return 'return/optional-special))
149 (with-test (:name (:return-from-frame :normal))
150 (test-return 'return/normal))
152 (defun throw-y () (throw 'y 'y))
154 ;; Check that *CURRENT-CATCH-BLOCK* was correctly restored.
155 (assert (eql (catch 'y
156 (test-return 'return/catch)
161 ;;;; Test RETURN-FROM-FRAME with local functions
163 (define-condition in-a () ())
164 (define-condition in-b () ())
173 (setf *a* (multiple-value-list (a)))
174 (setf *b* (multiple-value-list (b)))))
176 (defun hairy-locals ()
178 (flet ((a (&optional *c*)
184 ;; Ensure that A and B actually appear in the backtrace; the
185 ;; compiler for some reason likes to optimize away single-use
186 ;; local functions with hairy lambda-lists even on high debug
189 (setf *b* (b :*c* :good))
191 (setf *a* (multiple-value-list (a :good)))
192 (setf *b* (multiple-value-list (b :*c* :good))))))
194 (defun test-locals (name)
195 (handler-bind ((in-a (lambda (c)
197 (return-from-frame `(flet a :in ,name) 'x 'y)))
200 (return-from-frame `(flet b :in ,name) 'z))))
202 ;; We're intentionally not testing for returning a different amount
203 ;; of values than the local functions are normally returning. It's
204 ;; hard to think of practical cases where that'd be useful, but
205 ;; allowing it (as in the old fully CATCH-based implementation of
206 ;; UNWIND-TO-FRAME-AND-CALL) will make it harder for the compiler to
210 (assert (equal *a* '(x y)))
211 (assert (equal *b* '(z))))
212 (assert (eql *foo* 'x))))
214 (with-test (:name (:return-from-frame :local-function))
215 (test-locals 'locals))
217 (with-test (:name (:return-from-frame :hairy-local-function))
218 (test-locals 'hairy-locals))
221 ;;;; Test RETURN-FROM-FRAME with anonymous functions
223 (define-condition anon-condition () ())
225 (defparameter *anon-1*
227 (signal 'anon-condition)
230 (defparameter *anon-2*
232 (signal 'anon-condition)
235 (defun make-anon-3 ()
236 (let ((a (lambda (foo)
237 (signal 'anon-condition)
242 (defun make-anon-4 ()
243 (let ((a (lambda (*foo*)
244 (signal 'anon-condition)
249 (defparameter *anon-3* (make-anon-3))
250 (defparameter *anon-4* (make-anon-4))
252 (defun test-anon (fun var-name &optional in)
253 (handler-bind ((anon-condition (lambda (c)
256 `(lambda (,var-name) ,@(when in `(:in ,in)))
260 (assert (equal (multiple-value-list (funcall fun 1))
262 (assert (eql *foo* 'y)))
263 (assert (eql *foo* 'x)))))
265 (with-test (:name (:return-from-frame :anonymous :toplevel))
266 (test-anon *anon-1* 'foo (namestring *load-truename*)))
268 (with-test (:name (:return-from-frame :anonymous :toplevel-special))
269 (test-anon *anon-2* '*foo* (namestring *load-truename*)))
271 (with-test (:name (:return-from-frame :anonymous))
272 (test-anon *anon-3* 'foo 'make-anon-3))
274 (with-test (:name (:return-from-frame :anonymous :special))
275 (test-anon *anon-4* '*foo* 'make-anon-4))
278 ;;;; Test that unwind cleanups are executed
280 (defvar *unwind-state* nil)
281 (defvar *signal* nil)
286 (signal 'return-condition))
287 (push :unwind-1 *unwind-state*)))
292 (push :unwind-2 *unwind-state*)))
294 (defun test-unwind (fun wanted)
295 (handler-bind ((return-condition (lambda (c)
297 (return-from-frame fun
299 (dolist (*signal* (list nil t))
301 (*unwind-state* nil))
304 (assert (equal (multiple-value-list (funcall fun))
307 (assert (equal *unwind-state* wanted))
308 (assert (eql *foo* 'y)))
309 (assert (eql *foo* 'x))))))
311 (test-unwind 'unwind-1 '(:unwind-1))
312 (test-unwind 'unwind-2 '(:unwind-2 :unwind-1))
314 ;;; Regression in 1.0.10.47 reported by James Knight
319 (declaim (inline inline-fun))
320 (defun inline-fun (tla)
324 (defun foo (predicate)
325 (funcall predicate 2))
328 (let ((blah (foo #'inline-fun)))
331 (with-test (:name (:debug-instrumentation :inline/xep))