Avoid forward references to PARSE-mumble-TYPE condition classes.
[sbcl.git] / tests / win32-foreign-stack-unwind.impure.lisp
blob6749150740d575b6b6d424814bbfb57b68a2bead
1 ;;;; Testing the behavior of foreign calls trying to unwind the stack. Uses win32-stack-unwind.c.
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
14 #-win32 (exit :code 104) ;; This is extremely win32-specific.
15 #-x86 (exit :code 104) ;; And our AMD64 backend does not aim to support it.
17 (use-package :sb-alien)
19 ;;; Callbacks are not part of the exported interface yet -- when they are this can
20 ;;; go away.
21 (import 'sb-alien::alien-lambda)
23 ;;; XXX XXX this should change to use run-compiler.sh, now that we have it
24 (defun run-compiler ()
25 (let ((proc (run-program "gcc" '("win32-stack-unwind.c" "-shared"
26 "-o" "win32-stack-unwind.dll")
27 :search t)))
28 (unless (zerop (process-exit-code proc))
29 (error "Bad exit code: ~S"
30 (process-exit-code proc)))))
32 (run-compiler)
34 (load-shared-object (truename "win32-stack-unwind.dll"))
37 (defvar *current-test-callback*)
39 (defparameter *test-callback-thunk*
40 (sb-alien::alien-callback
41 (function void)
42 #'(lambda () (funcall *current-test-callback*))))
44 (defun establish-return-frame (callback)
45 "Establish an SEH frame for use as a target with PERFORM-TEST-UNWIND and invoke CALLBACK via FUNCALL"
46 ;; We don't use a LET here because we don't want to accidentally
47 ;; correct a blown binding stack pointer just yet.
48 (setf *current-test-callback* callback)
49 (alien-funcall (extern-alien "establish_return_frame"
50 (function void (* (function void))))
51 (alien-sap *test-callback-thunk*))
52 (makunbound '*current-test-callback*)
53 (values))
55 (defun perform-test-unwind ()
56 "Perform an RtlUnwind to the surrounding ESTABLISH-RETURN-FRAME frame."
57 (alien-funcall (extern-alien "perform_test_unwind" (function void))))
60 ;;; An attempt to detect and clean up latent fatalities in the
61 ;;; post-test environent.
63 (defmacro with-test-environment (args &body body)
64 (declare (ignore args))
65 (let ((old-bsp (gensym))
66 (old-cuwp (gensym))
67 (old-ccb (gensym))
68 (old-asp (gensym)))
69 `(let ((*standard-input* *standard-input*))
70 (let ((,old-bsp (+ sb-vm::*binding-stack-pointer* 2))
71 (,old-cuwp sb-vm::*current-unwind-protect-block*)
72 (,old-ccb sb-vm:*current-catch-block*)
73 (,old-asp sb-vm::*alien-stack-pointer*))
74 (handler-case
75 (let ((result (progn ,@body))
76 extra-results)
77 (when (not (eql ,old-bsp sb-vm::*binding-stack-pointer*))
78 #+(or)
79 (format t "~A ~A~%" ,old-bsp sb-vm::*binding-stack-pointer*)
80 (push :bsp-fail extra-results))
81 (when (not (eql ,old-cuwp sb-vm::*current-unwind-protect-block*))
82 (push :cuwp-fail extra-results))
83 (when (not (eql ,old-ccb sb-vm:*current-catch-block*))
84 (push :ccb-fail extra-results))
85 (when (not (eql ,old-asp sb-vm::*alien-stack-pointer*))
86 (push :asp-fail extra-results))
87 (setf sb-vm::*current-unwind-protect-block* ,old-cuwp)
88 (setf sb-vm:*current-catch-block* ,old-ccb)
89 (setf sb-vm::*alien-stack-pointer* ,old-asp)
90 (list* result extra-results))
91 (error ()
92 :error))))))
95 ;;; Test cases.
97 (with-test (:name #1=:base-case)
98 ;; Tests that the unwind test machinery works.
99 (let ((result
100 (with-test-environment ()
101 (establish-return-frame (lambda () (perform-test-unwind)))
102 :success)))
103 (format t "~S result: ~S~%" #1# result)
104 (assert (eql :success (car result)))))
106 (with-test (:name #1=:special-binding)
107 ;; Tests that special bindings are undone properly during
108 ;; unwind.
109 (let ((result
110 (with-test-environment ()
111 (let ((foo :success))
112 (declare (special foo))
113 (establish-return-frame (lambda ()
114 (let ((foo nil))
115 (declare (special foo))
116 (perform-test-unwind))))
117 foo))))
118 (format t "~S result: ~S~%" #1# result)
119 (assert (eql :success (car result)))))
121 (with-test (:name #1=:unwind-protect)
122 ;; Tests that unwind-protect forms are run during unwind.
123 (let ((result
124 (with-test-environment ()
125 (let (result)
126 (establish-return-frame (lambda ()
127 (unwind-protect
128 (perform-test-unwind)
129 (setf result :success))))
130 result))))
131 (format t "~S result: ~S~%" #1# result)
132 (assert (eql :success (car result)))))
134 (with-test (:name #1=:unwind-protect-nlx)
135 ;; Tests that unwind-protect forms that are run during unwind
136 ;; can do a non-local exit to abort the unwind.
137 (let ((result
138 (with-test-environment ()
139 (let (result)
140 (establish-return-frame (lambda ()
141 (block nil
142 (unwind-protect
143 (perform-test-unwind)
144 (return)))
145 (setf result :success)))
146 result))))
147 (format t "~S result: ~S~%" #1# result)
148 (assert (eql :success (car result)))))
150 (with-test (:name #1=:no-unwind)
151 ;; Basic smoke test of establish-return-frame.
152 (let ((result
153 (with-test-environment ()
154 (establish-return-frame (lambda ()))
155 :success)))
156 (format t "~S result: ~S~%" #1# result)
157 (assert (eql :success (car result)))))
159 (with-test (:name #1=:no-unwind-error)
160 ;; Tests that EXCEPTION_BREAKPOINT is caught and handled
161 ;; correctly within callbacks.
162 (let ((result
163 (with-test-environment ()
164 (establish-return-frame (lambda ()
165 (handler-case
166 (some-undefined-function)
167 (undefined-function ()))))
168 :success)))
169 (format t "~S result: ~S~%" #1# result)
170 (assert (eql :success (car result)))))
172 (with-test (:name #1=:unwind-foreign-frame)
173 ;; Tests that unwinding a foreign SEH frame isn't completely
174 ;; broken.
175 (let ((result
176 (with-test-environment ()
177 (block nil
178 (establish-return-frame (lambda () (return :success)))))))
179 (format t "~S result: ~S~%" #1# result)
180 (assert (eql :success (car result)))))
182 (with-test (:name #1=:unwind-protect-unwind-foreign-frame)
183 ;; Tests that an unwind-protect block is allowed to unwind
184 ;; past the original unwind target.
185 (let ((result
186 (with-test-environment ()
187 (block nil
188 (establish-return-frame (lambda ()
189 (unwind-protect
190 (perform-test-unwind)
191 (return :success))))))))
192 (format t "~S result: ~S~%" #1# result)
193 (assert (eql :success (car result)))))
195 (with-test (:name #1=:unwind-error)
196 ;; Another test for unwinding an SEH frame.
197 (let ((result
198 (with-test-environment ()
199 (handler-case
200 (establish-return-frame (lambda ()
201 (error "Foo!")))
202 (error ()
203 :success)))))
204 (format t "~S result: ~S~%" #1# result)
205 (assert (eql :success (car result)))))
207 ;;;; success!